home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
snobol4
/
v311sil.arc
/
v311.sil
Wrap
Text File
|
1993-07-24
|
245KB
|
6,578 lines
TITLE 'Table of Contents'
*
*
* E32 (DECEMBER 18, 1969) V3.7
* UPDATED TO VERSION 3.10, NOV. 1, 1972 V3.10
*
* UPDATED TO VERSION 3.11, MAY 19, 1975. V3.11
* RESEQUENCED DECEMBER 20, 1980. V3.11
* Corrected April 10, 1985 (lines 3393 and 5033).
* 1. Linkage and Equivalences
* Linkage
* Machine Dependent Parameters
* Constants
* Equivalences
* Data Type Codes
* 2. Program Initialization
* 3. Compilation and Interpreter Invocation
* 4. Support Procedures
* AUGATL
* CODSKP
* DTREP
* FINDEX
* 5. Storage Allocation and Regeneration Procedures
* BLOCK
* GENVAR
* GNVARI
* CONVAR
* GNVARS
* GC
* GCM
* SPLIT
* 6. Compilation Procedures
* BINOP
* CMPILE
* ELEMNT
* EXPR
* FORWRD
* NEWCRD
* TREPUB
* UNOP
* 7. Interpreter Executive and Control Procedures
* BASE
* GOTG
* GOTL
* GOTO
* INIT
* INTERP
* INVOKE
* 8. Argument Evaluation Procedures
* ARGVAL
* EXPVAL
* EXPEVL
* EVAL
* INTVAL
* PATVAL
* VARVAL
* XYARGS
* 9. Arithmetic Operations, Predicates and Functions
* ADD
* DIV
* EXP
* MPY
* SUB
* EQ
* GE
* GT
* LE
* LT
* NE
* REMDR
* INTGER
* MNS
* PLS
* 10. Pattern-Valued Functions and Operations
* ANY
* BREAK
* NOTANY
* SPAN
* LEN
* POS
* RPOS
* RTAB
* TAB
* ARBNO
* ATOP (Cursor Position)
* NAM (Value Assignment)
* OR
* 11. Pattern Matching Procedures
* SCAN
* SJSR (Scan and Replace)
* SCNR (Basic Scanner)
* ANYC
* BRKC
* NNYC
* SPNC
* LNTH
* POSI
* RPSI
* RTB
* TB
* ARBN (ARBNO)
* FARB (ARB Backup)
* ATP (Cursor Position)
* BAL
* CHAR
* STAR (Unevaluated Expression)
* DSAR
* FNCE
* NME (Value Assignment)
* ENME
* DNME
* ENMI (Immediate Value Assignment)
* SUCE (SUCCEED)
* 12. Defined Functions
* DEFINE
* DEFFNC (Invoke Defined Function)
* 13. External Functions
* LOAD
* UNLOAD
* LNKFNC (Link to External Function)
* 14. Arrays, Tables, and Defined Data Objects
* ARRAY
* ASSOC (TABLE)
* DATDEF (DATA)
* PROTO
* ITEM (Array and Table References)
* DEFDAT (Create Data Object)
* FIELD
* 15. Input and Output
* READ (INPUT)
* PRINT (OUTPUT)
* BKSPCE
* ENFILE
* REWIND
* DETACH
* PUTIN
* PUTOUT
* 16. Tracing Procedures and Functions
* TRACE
* STOPTR
* FENTR (Call Tracing)
* FENTR2
* KEYTR
* TRPHND (Trace Handler)
* VALTR
* FNEXT2
* 17. Other Operations
* ASGN (=)
* CON (Concatenation)
* IND (Indirect Reference)
* KEYWRD
* LIT
* NAME
* NMD (Value Assignment)
* STR (Unevaluated Expression)
* 18. Other Predicates
* DIFFER
* IDENT
* LGT
* NEG
* QUES (?)
* 19. Other Functions
* APPLY
* ARG
* LOCAL
* FIELDS
* CLEAR
* COLECT
* COPY
* CNVRT
* DATE
* DT
* DMP
* DUMP
* DUPL
* OPSYN
* RPLACE
* SIZE
* TIME
* TRIM
* 20. Common Code
* 21. Termination
* END
* FTLEND
* SYSCUT
* 22. Error Handling
* 23. Data
* Pair Lists
* Data Type Pairs
* Switches
* Constants
* Pointers to Patterns
* Function Descriptors
* Miscellaneous Data
* Program Pointers
* Pointers to Specifiers
* Permanent Pair List Pointers
* Specifiers for Compilation
* Strings and Specifiers
* Character Buffers
* Pointers to Pair Lists
* Scratch Descriptors
* System Descriptors
* Compiler Descriptors
* Data Pointers
* Specifiers
* Allocator Data
* Machine Dependent Data
* Function Table
* Function Pair List
* Function Initialization Data
* Pointers to Initialization Data
* System Arrays
* String Storage Bin List
* Pattern-Matching History List
* System Stack
* Primitive Patterns
* Code Skeleton for TRACE
* Fatal Error Message Pointers
* Fatal Error Messages
* Compiler Error Messages
* Formats
*
TITLE 'Linkage and Equivalences'
COPY MLINK Linkage segment
COPY PARMS Machine-dependent parameters
*
* Constants
*
ATTRIB EQU 2*DESCR Offset of label in string structure
LNKFLD EQU 3*DESCR Offset of link in string structure
BCDFLD EQU 4*DESCR Offset of string in string structure
FATHER EQU DESCR Offset of father in code node
LSON EQU 2*DESCR Offset of left son in code node
RSIB EQU 3*DESCR Offset of right sibling in code node
CODE EQU 4*DESCR Offset of code in code node
ESASIZ EQU 50 Limit on number of syntactic errors
FBLKSZ EQU 10*DESCR Size of function descriptor block
ARRLEN EQU 20 Limit on length of array print image
CARDSZ EQU 80 Width of compiler input
SEQSIZ EQU 8 Width of sequence field
STNOSZ EQU 8 Length of statement number field
DSTSZ EQU 2*STNOSZ Space for left and right numbering
CNODSZ EQU 4*DESCR Size of code node
DATSIZ EQU 1000 Limit on number of defined data type
EXTSIZ EQU 10 Default allocation for tables
NAMLSZ EQU 20 Growth quantum for name list
NODESZ EQU 3*DESCR Size of pattern node
OBSIZ EQU 256 Number of bin headers
OBARY EQU OBSIZ+3 Total number for bins
OCASIZ EQU 1500 Descriptors of initial object code
SPDLSZ EQU 1000 Descriptors of pattern stack
STSIZE EQU 1000 Descriptors of interpreter stack
SPDR EQU SPEC+DESCR Descriptor plus specifier
OBOFF EQU OBSIZ-2 Offset length in bins
SPDLDR EQU SPDLSZ*DESCR Size of pattern stack
*
* Equivalences
*
ARYTYP EQU 7 Array reference
CLNTYP EQU 5 Goto field
CMATYP EQU 2 Comma
CMTTYP EQU 2 Comment card
CNTTYP EQU 4 Continue card
CTLTYP EQU 3 Control card
DIMTYP EQU 1 Dimension separator
EOSTYP EQU 6 End of statement
EQTYP EQU 4 Equal sign
FGOTYP EQU 3 Failure goto
FTOTYP EQU 6 Failure direct goto
FLITYP EQU 6 Literal real
FNCTYP EQU 5 Function call
ILITYP EQU 2 Literal integer
LPTYP EQU 1 Left parenthesis
NBTYP EQU 1 Nonbreak character
NEWTYP EQU 1 New statement
NSTTYP EQU 4 Parenthesized expression
QLITYP EQU 1 Quoted literal
RBTYP EQU 7 Right bracket
RPTYP EQU 3 Right parenthesis
SGOTYP EQU 2 Success goto
STOTYP EQU 5 Success direct goto
UGOTYP EQU 1 Unconditional goto
UTOTYP EQU 4 Unconditional direct goto
VARTYP EQU 3 Variable
*
* Data type Codes
*
A EQU 4 ARRAY
B EQU 2 BLOCK (internal)
C EQU 8 CODE
E EQU 11 EXPRESSION
I EQU 6 INTEGER
K EQU 10 KEYWORD (NAME)
L EQU 12 LINKED STRING (internal)
N EQU 9 NAME
P EQU 3 PATTERN
R EQU 7 REAL
S EQU 1 STRING
T EQU 5 TABLE
*---------------------------------------------------------------------*
TITLE 'Program Initialization'
BEGIN INIT , Initialize system
ISTACK , Initialize stack
OUTPUT OUTPUT,TITLEF Title listing
OUTPUT OUTPUT,SOURCF Print attribution
MSTIME TIMECL Time in compiler
RCALL SCBSCL,BLOCK,OCALIM Allocate block for object code
MOVD OCSVCL,SCBSCL Save object code pointer
RESETF SCBSCL,PTR Clear pointer flag
GETSIZ YCL,INITLS Get size of initialization list
SPCNVT GETD XPTR,INITLS,YCL Get pointer to list
GETSIZ XCL,XPTR Get size of list
SPCNV1 GETD ZPTR,XPTR,XCL Get pointer to specifier
AEQLC ZPTR,0,,SPCNV2 Skip dummy zero entries
RCALL ZPTR,GENVAR,ZPTR Convert specifier to structure
PUTD XPTR,XCL,ZPTR Replace pointer to specifier
SPCNV2 DECRA XCL,2*DESCR Decrement to next pair
ACOMPC XCL,0,SPCNV1 Continue if one remains
DECRA YCL,DESCR Decrement to next list
ACOMPC YCL,0,SPCNVT Continue if one remains
INITD1 GETDC XPTR,INITB,0 Get specifier to convert
RCALL YPTR,GENVAR,(XPTR) Convert it to string structure
GETDC ZPTR,INITB,DESCR Get location to put it
PUTDC ZPTR,0,YPTR Place pointer to string structure
INCRA INITB,2*DESCR Decrement to next pair
ACOMP INITB,INITE,,,INITD1
* Compare with end
*
PUTDC ABRTKY,DESCR,ABOPAT Initial value of ABORT
PUTDC ARBKY,DESCR,ARBPAT Initial value of ARB
PUTDC BALKY,DESCR,BALPAT Initial value of BAL
PUTDC FAILKY,DESCR,FALPAT Initial value of FAIL
PUTDC FNCEKY,DESCR,FNCPAT Initial value of FENCE
PUTDC REMKY,DESCR,REMPAT Initial value of REM
PUTDC SUCCKY,DESCR,SUCPAT Initial value of SUCCEED
*
SETAC VARSYM,0 Set count of variables to zero
RCALL NBSPTR,BLOCK,NMOVER Allocate block for value assignment
MOVD CMBSCL,SCBSCL Set up pointer for compiler
MOVD UNIT,INPUT Set up input unit
MOVD OCBSCL,CMBSCL Project base for interpreter
SUM OCLIM,CMBSCL,OCALIM Compute end of code block
DECRA OCLIM,5*DESCR Leave room for overflow
SETAC INICOM,1 SIGNAL COMPLETION E3.10.6
BRANCH XLATRN
*_
*---------------------------------------------------------------------*
TITLE 'Compilation and Interpreter Invocation'
XLATRD AEQLC LISTCL,0,,XLATRN Skip print if list is off
STPRNT IOKEY,OUTBLK,LNBFSP Print line image
XLATRN STREAD INBFSP,UNIT,XLATRN,COMP5
SETSP TEXTSP,NEXTSP Read card and set up line
STREAM XSP,TEXTSP,CARDTB,COMP3,COMP3
* Determine type of card
RCALL ,NEWCRD,,(XLATRD,,) Process card type
XLATNX RCALL ,CMPILE,,(COMP3,,XLATNX)
* Compile statement
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,ENDCL Insert END function
AEQLC LISTCL,0,,XLATP Skip print if list is off
STPRNT IOKEY,OUTBLK,LNBFSP Print last line image
XLATP AEQLC STYPE,EOSTYP,,XLAEND
* Finish on end of statement
STREAM XSP,TEXTSP,IBLKTB,COMP3,XLAEND
* Analyze END card
AEQLC STYPE,EOSTYP,,XLAEND
* Finish on end of statement
AEQLC STYPE,NBTYP,COMP7 Error if break character
STREAM XSP,TEXTSP,LBLTB,COMP7,COMP7
* Analyze END label
RCALL XPTR,GENVAR,(XSPPTR)
* Generate variable for label
GETDC OCBSCL,XPTR,ATTRIB Get start for interpreter
AEQLC OCBSCL,0,,COMP7 Error if not attribute
AEQLC STYPE,EOSTYP,,XLAEND
* Finish on end of statement
STREAM XSP,TEXTSP,IBLKTB,COMP7,,COMP7
* Analyze remainder of card
XLAEND AEQLC ESAICL,0,,XLATSC Were there any compilation errors?
OUTPUT OUTPUT,ERRCF Print message of errors
BRANCH XLATND
*_
XLATSC OUTPUT OUTPUT,SUCCF Print message of no errors
XLATND SETAC UNIT,0 Reset input unit
SETAC LPTR,0 Reset last label pointer
SETAC OCLIM,0 Reset limit on object code
ZERBLK COMREG,COMDCT Clear compiler descriptors
SUM XCL,CMBSCL,CMOFCL Compute end of object code
RCALL ,SPLIT,(XCL) Split of unused part of block
SETAC LISTCL,0 Turn off listing switch
MSTIME ETMCL Time out compiler
SUBTRT TIMECL,ETMCL,TIMECL Compute elapsed time
SETAC CNSLCL,1 Permit label redefinition
RCALL ,INTERP,,(MAIN1,MAIN1,MAIN1)
* Call interpreter
*_
*---------------------------------------------------------------------*
TITLE 'Support Procedures'
*
* Augmentation of Pair Lists
*
AUGATL PROC , Procedure to augment pair lists
POP (A1PTR,A2PTR,A3PTR) List, type and value
LOCAPT A4PTR,A1PTR,ZEROCL,AUG1
* Look for hole in list
PUTDC A4PTR,DESCR,A2PTR Insert type descriptor
PUTDC A4PTR,2*DESCR,A3PTR Insert value descriptor
MOVD A5PTR,A1PTR Set up return pointer
BRANCH A5RTN Return pair list
*_
AUG1 GETSIZ A4PTR,A1PTR Get size of present list
INCRA A4PTR,2*DESCR Add two more descriptors
SETVC A4PTR,B Insert BLOCK data type
RCALL A5PTR,BLOCK,A4PTR Allocate new block
PUTD A5PTR,A4PTR,A3PTR Insert value descriptor at end
DECRA A4PTR,DESCR Decrement
PUTD A5PTR,A4PTR,A2PTR Insert type descriptor above
AUGMOV DECRA A4PTR,DESCR Adjust size
MOVBLK A5PTR,A1PTR,A4PTR Copy old list at top
BRANCH A5RTN Return new list
*_
*---------------------------------------------------------------------*
*
* Code Skipping Procedure
*
CODSKP PROC , Procedure to skip object code
POP YCL Restore number of items to skip
CODCNT INCRA OCICL,DESCR Increment offset
GETD XCL,OCBSCL,OCICL Get object code descriptor
TESTF XCL,FNC,,CODFNC Check for function
CODECR DECRA YCL,1 Count down
ACOMPC YCL,0,CODCNT,RTN1,INTR10
* Check for end
*_
CODFNC PUSH YCL Save number to skip
SETAV YCL,XCL Get arguments to skip
RCALL ,CODSKP,(YCL) Call self recursively
POP YCL Restore number to skip
BRANCH CODECR Go around again
*_
*---------------------------------------------------------------------*
*
* Data Type Representation
*
DTREP PROC , Procedure to represent data type
POP A2PTR Restore object
VEQLC A2PTR,A,,DTARRY Is is ARRAY?
VEQLC A2PTR,T,,DTABLE Is it TABLE?
VEQLC A2PTR,R,DTREP1 Is it REAL?
REALST DPSP,A2PTR Convert REAL to STRING
BRANCH DTREPR Join end processing
*_
DTARRY GETDC A3PTR,A2PTR,DESCR Get prototype
LOCSP ZSP,A3PTR Get specifier
GETLG A3PTR,ZSP Get length
ACOMPC A3PTR,ARRLEN,DTREP1 Check for excessive length
SETLC DTARSP,0 Clear specifier
APDSP DTARSP,ARRSP Append ARRAY
APDSP DTARSP,LPRNSP Append '('
APDSP DTARSP,QTSP Append quote
APDSP DTARSP,ZSP Append prototype
APDSP DTARSP,QTSP Append quote
DTARTB APDSP DTARSP,RPRNSP Append ')'
SETSP DPSP,DTARSP Move specifier
BRANCH DTREPR Return
*_
DTABLE GETSIZ A3PTR,A2PTR E3.2.3
GETD A1PTR,A2PTR,A3PTR E3.2.3
DECRA A3PTR,DESCR E3.2.3
GETD A2PTR,A2PTR,A3PTR E3.2.3
DTABL1 AEQLC A1PTR,1,,DTABL2 E3.2.3
SUM A3PTR,A3PTR,A2PTR E3.2.3
DECRA A3PTR,2*DESCR E3.2.3
GETD A1PTR,A1PTR,A2PTR E3.2.3
BRANCH DTABL1 E3.2.3
*_ E3.2.3
DTABL2 DECRA A3PTR,DESCR E3.2.3
DECRA A2PTR,2*DESCR E3.2.3
DIVIDE A3PTR,A3PTR,DSCRTW Divide to get item count
INTSPC ZSP,A3PTR Convert to string
SETLC DTARSP,0 Clear specifier
APDSP DTARSP,ASSCSP Append TABLE
APDSP DTARSP,LPRNSP Append '('
APDSP DTARSP,ZSP Append size
APDSP DTARSP,CMASP Append comma
DIVIDE A2PTR,A2PTR,DSCRTW E3.2.3
INTSPC ZSP,A2PTR E3.2.3
APDSP DTARSP,ZSP Append extent
BRANCH DTARTB Join common processing
*_
DTREP1 MOVV DT1CL,A2PTR Insert data type
LOCAPT A3PTR,DTATL,DT1CL,DTREPE
* Look for data type name
GETDC A3PTR,A3PTR,2*DESCR Get data type name
LOCSP DPSP,A3PTR Get specifier
DTREPR RRTURN DPSPTR,1 Return pointer to specifier
*_
DTREPE SETSP DPSP,EXDTSP Set up EXTERNAL specifier
BRANCH DTREPR Return
*_
*---------------------------------------------------------------------*
*
* Location of Function Descriptor
*
FINDEX PROC , Procedure to get function descriptor
POP F1PTR Restore name
LOCAPV F2PTR,FNCPL,F1PTR,FATNF
* Look for function pair
GETDC F2PTR,F2PTR,DESCR Get function descriptor
FATBAK RRTURN F2PTR,1 Return
*_
FATNF INCRA NEXFCL,2*DESCR Increment function block offset
ACOMPC NEXFCL,FBLKSZ,FATBLK
* Check for end
FATNXT SUM F2PTR,FBLOCK,NEXFCL Compute position
RCALL FNCPL,AUGATL,(FNCPL,F2PTR,F1PTR)
* Augment function pair list
PUTDC F2PTR,0,UNDFCL Insert undefined function
PUTDC F2PTR,DESCR,F1PTR Insert name
BRANCH FATBAK Join return
*_
FATBLK RCALL FBLOCK,BLOCK,FBLKRQ Allocate new function block
SETF FBLOCK,FNC Insert function flag
SETVC FBLOCK,0 Clear data type
SETAC NEXFCL,DESCR Initialize offset
BRANCH FATNXT Join processing
*_
*---------------------------------------------------------------------*
TITLE 'Storage Allocation and Regeneration Procedures'
*
* Allocation of Block
*
BLOCK PROC , Procedure to allocate blocks
POP ARG1CL Restore size to allocate
ACOMP ARG1CL,SIZLMT,SIZERR,SIZERR
* Check against size limit
BLOCK1 MOVD BLOCL,FRSGPT Position pointer to title
MOVV BLOCL,ARG1CL Move data type
INCRA FRSGPT,DESCR Leave room for title
SUM FRSGPT,FRSGPT,ARG1CL
* Move position pointer past end
ACOMP TLSGP1,FRSGPT,,,BLOGC
* Check for end of region
ZERBLK BLOCL,ARG1CL Clear block
PUTAC BLOCL,0,BLOCL Set up self-pointer in title
SETFI BLOCL,TTL Insert title flag
SETSIZ BLOCL,ARG1CL Insert block size
RRTURN BLOCL,1 Return pointer to block
*_
BLOGC MOVA FRSGPT,BLOCL Restore position pointer
RCALL ,GC,(ARG1CL),(ALOC2,BLOCK1)
* Regenerate storage
*_
*---------------------------------------------------------------------*
*
* Generation of Natural Variables
*
GENVAR PROC , Procedure to generate variable
SETAC CONVSW,0 Note GENVAR entry
POP AXPTR Resotre pointer to specifier
GETSPC SPECR1,AXPTR,0 Get specifier
LEQLC SPECR1,0,,RT1NUL Avoid null string
LOCA1 VARID EQUVCL,SPECR1 Compute bin and ascension numbers
SUM BUKPTR,OBPTR,EQUVCL Find bin
LOCA2 MOVD LSTPTR,BUKPTR Save working copy
GETAC BUKPTR,BUKPTR,LNKFLD
* Get link descriptor
AEQLC BUKPTR,0,,LOCA5 Check for end of chain
VCMPIC BUKPTR,LNKFLD,EQUVCL,LOCA5,,LOCA2
* Compare ascension numbers
LOCSP SPECR2,BUKPTR Get specifier to string in storage
LEXCMP SPECR1,SPECR2,LOCA2,,LOCA2
* Compare strings
MOVD LCPTR,BUKPTR Return string in storage
BRANCH LOCRET
*_
LOCA5 GETLG AXPTR,SPECR1 Get length of string
GETLTH BKLTCL,AXPTR Compute space required
ACOMP BKLTCL,SIZLMT,SIZERR
* Check against size limit
LOCA7 MOVD LCPTR,FRSGPT Point to position in storage
SETVC LCPTR,S Set data type to STRING
INCRA FRSGPT,DESCR Leave space for title
SUM FRSGPT,FRSGPT,BKLTCL
* Skip required space
ACOMP TLSGP1,FRSGPT,,,LOCA4
* Check for end of region
PUTDC LCPTR,0,ZEROCL Clear title
PUTAC LCPTR,0,LCPTR Point title to self
SETFI LCPTR,TTL+STTL Set string and title flags
SETSIZ LCPTR,AXPTR Insert size of string
AEQLC CONVSW,0,LOCA6 Check for GENVAR entry
PUTDC LCPTR,DESCR,NULVCL Set value to null string
PUTDC LCPTR,ATTRIB,ZEROCL Set label attribute to zero
LOCSP SPECR2,LCPTR Get specifier to string structure
SETLC SPECR2,0 Clear length
APDSP SPECR2,SPECR1 Move new string in
LOCA6 PUTVC LCPTR,LNKFLD,EQUVCL Insert ascension number
PUTAC LCPTR,LNKFLD,BUKPTR Insert link pointer
PUTAC LSTPTR,LNKFLD,LCPTR Link to last structure
INCRA VARSYM,1 Increment count of new variables
LOCRET RRTURN LCPTR,1 Return pointer to structure
*_
LOCA4 MOVA FRSGPT,LCPTR Restore position pointer
RCALL ,GC,(BKLTCL),(ALOC2,LOCA7)
* Regenerate storage
*_
*---------------------------------------------------------------------*
*
* Generation of Variable from Integer
*
GNVARI PROC GENVAR Procedure to generate string
SETAC CONVSW,0 Note GENVAR entry
POP AXPTR Restore integer
INTSPC SPECR1,AXPTR Convert to string
BRANCH LOCA1 Join processing
*_
*---------------------------------------------------------------------*
*
* Allocation of Space for Variable
*
CONVAR PROC GENVAR Procedure to get space for variable
POP AXPTR Restore length
AEQLC AXPTR,0,,RT1NUL Avoid null string
SETAC CONVSW,1 Note CONVAR entry
GETLTH BKLTCL,AXPTR Get space required
ACOMP BKLTCL,SIZLMT,SIZERR
* Check against size limit
SUM TEMPCL,FRSGPT,BKLTCL
* Skip required space
INCRA TEMPCL,DESCR Save space for title
ACOMP TLSGP1,TEMPCL,,,CONVR4
* Check for end of region
CONVR5 PUTDC FRSGPT,0,ZEROCL Clear title
PUTAC FRSGPT,0,FRSGPT Set up self pointer
SETFI FRSGPT,TTL+STTL Set string and title flags
SETSIZ FRSGPT,AXPTR Insert tentative size of string
PUTDC FRSGPT,DESCR,NULVCL Insert null string as value
PUTDC FRSGPT,ATTRIB,ZEROCL
* Set label to zero
MOVA BKLTCL,FRSGPT E3.3.2
RRTURN BKLTCL,1 E3.3.2
*_
CONVR4 RCALL ,GC,BKLTCL,(ALOC2,CONVR5)
* Regenerate storage
*_
*---------------------------------------------------------------------*
*
* Generation of Variable in Place
*
GNVARS PROC GENVAR Procedure to entry string
POP AXPTR Restore length
AEQLC AXPTR,0,,RT1NUL Avoid null string
LOCSP SPECR1,FRSGPT Get specifier to position
PUTLG SPECR1,AXPTR Insert final length
SETSIZ FRSGPT,AXPTR Insert size in title
BRANCH LOCA1 Join processing
*_
*---------------------------------------------------------------------*
*
* Storage Regeneration
*
GC PROC , Storage regeneration procedure
POP GCREQ Restore space required
PSTACK BLOCL Post stack position
SUBTRT BLOCL,BLOCL,STKPTR Compute stack length used
SETSIZ STKPTR,BLOCL Set stack size
MOVD BKDXU,PRMDX Number of resident blocks
GCT GETD GCMPTR,PRMPTR,BKDXU Get next resident block
AEQLC GCMPTR,0,,GCTDWN Skip nonpointers
RCALL ,GCM,(GCMPTR) Scan resident block
GCTDWN DECRA BKDXU,DESCR Decrement block count
AEQLC BKDXU,0,GCT Test for end of loop
SETAC BKPTR,OBLIST-DESCR Set up pointer to bins
GCBA1 ACOMP BKPTR,OBEND,GCLAD Check for end of bins
INCRA BKPTR,DESCR Increment bin pointer
MOVD ST1PTR,BKPTR Get working copy
GCBA2 GETAC ST1PTR,ST1PTR,LNKFLD
* Get link pointer
AEQLC ST1PTR,0,,GCBA1 Test for end of chain
TESTFI ST1PTR,MARK,,GCBA2 Test for marked structure
GETDC ST2PTR,ST1PTR,DESCR Get value descriptor
DEQL ST2PTR,NULVCL,GCBA4 Mark if nonnull
AEQLIC ST1PTR,ATTRIB,0,,GCBA2
* Test attribute also
GCBA4 PUTDC GCBLK,DESCR,ST1PTR Set up pseudoblock
RCALL ,GCM,(GCBLK),GCBA2 Mark string structure
*_
GCLAD MOVD CPYCL,HDSGPT Initialize target pointer
MOVD TTLCL,HDSGPT Initialize block pointer
GCLAD0 BKSIZE BKDX,TTLCL Get size of block
TESTFI TTLCL,MARK,GCLAD7 Is the block marked?
SUM CPYCL,CPYCL,BKDX Is block marked?
SUM TTLCL,TTLCL,BKDX Update block pointer
AEQL TTLCL,FRSGPT,GCLAD0,GCBB1
* Check for end of region
*_
GCLAD7 MOVD MVSGPT,TTLCL Update compression barrier
GCLAD4 SUM TTLCL,TTLCL,BKDX Update block pointer
AEQL TTLCL,FRSGPT,,GCBB1 Check for end of region
BKSIZE BKDX,TTLCL Get size of block
TESTFI TTLCL,MARK,GCLAD4 Is block marked?
PUTAC TTLCL,0,CPYCL Point title to target
SUM CPYCL,CPYCL,BKDX Update target pointer
BRANCH GCLAD4 Continue
*_
GCBB1 SETAC BKPTR,OBLIST-DESCR Set up pointer to bins
SETAC NODPCL,1 No dump while reorganizing
GCBB2 ACOMP BKPTR,OBEND,GCLAP Check for end of bins
INCRA BKPTR,DESCR Increment bin pointer
MOVD ST1PTR,BKPTR Get work copy
GCBB3 MOVD ST2PTR,ST1PTR Save pointer to be linked
GCBB4 GETAC ST1PTR,ST1PTR,LNKFLD
* Get link pointer
AEQLC ST1PTR,0,,GCBB5 Check for end of chain
TESTFI ST1PTR,MARK,GCBB4 Is string marked?
GETAC BLOCL,ST1PTR,0 Get target address
PUTAC ST2PTR,LNKFLD,BLOCL Set link to target
BRANCH GCBB3 Continue
*_
GCBB5 PUTAC ST2PTR,LNKFLD,ZEROCL
* Set last link to zero
BRANCH GCBB2 Continue
*_
GCLAP MOVD TTLCL,HDSGPT Initialize target pointer
GCLAP0 BKSIZE BKDXU,TTLCL Get size of block
TESTFI TTLCL,STTL,,GCLAP1 Check for string
MOVD BKDX,BKDXU Working copy of block size
BRANCH GCLAP2
*_
GCLAP1 SETAC BKDX,3*DESCR Three descriptors for string
GCLAP2 TESTFI TTLCL,MARK,GCLAP5 Is block marked?
DECRA BKDX,DESCR Decrement offset
GCLAP3 GETD DESCL,TTLCL,BKDX Get next descriptor in block
TESTF DESCL,PTR,GCLAP4 Is it a pointer?
ACOMP DESCL,MVSGPT,,,GCLAP4
* Is it above compression barrier?
TOP TOPCL,OFSET,DESCL Compute offset to target
ADJUST DESCL,TOPCL,OFSET Adjust pointer to target
PUTD TTLCL,BKDX,DESCL Put descriptor back in block
GCLAP4 DECRA BKDX,DESCR Decrement offset
AEQLC BKDX,0,GCLAP3 Check for end of block
GCLAP5 SUM TTLCL,TTLCL,BKDXU Move to next block
AEQL TTLCL,FRSGPT,GCLAP0 Check for end of region
MOVD BKDXU,PRMDX Number of resident blocks
GCLAT1 GETD TTLCL,PRMPTR,BKDXU Get next resident block
AEQLC TTLCL,0,,GCLAT4 Skip nonpointer
GETSIZ BKDX,TTLCL Get size of block
GCLAT2 GETD DESCL,TTLCL,BKDX Get descriptor from block
TESTF DESCL,PTR,GCLAT3 Is it a pointer?
ACOMP DESCL,MVSGPT,,,GCLAT3
* Is it above compression barrier?
TOP TOPCL,OFSET,DESCL Compute offset to target
ADJUST DESCL,TOPCL,OFSET Adjust pointer to target
PUTD TTLCL,BKDX,DESCL Put descriptor back in block
GCLAT3 DECRA BKDX,DESCR Decrement offset
AEQLC BKDX,0,GCLAT2 Check for end of block
GCLAT4 DECRA BKDXU,DESCR Decrement count of resident blocks
AEQLC BKDXU,0,GCLAT1 Check for end of resident blocks
MOVD TTLCL,HDSGPT Set up target pointer
GCLAM0 BKSIZE BKDXU,TTLCL Get size of block
ACOMP TTLCL,MVSGPT,GCLAM5,GCLAM5
* Has compression barrier been reached
GETAC TOPCL,TTLCL,0 Get target position
MOVDIC TOPCL,0,TTLCL,0 Move title to target position
RSETFI TOPCL,MARK Clear mark flag
BRANCH GCLAM4 Continue
*_
GCLAM5 MOVA BKDX,BKDXU Working copy of block size
DECRA BKDX,DESCR Size to be moved
TESTFI TTLCL,MARK,GCLAM4 Is block marked?
GETAC TOPCL,TTLCL,0 Get target position
MOVDIC TOPCL,0,TTLCL,0 Move title
RSETFI TOPCL,MARK Clear mark flag
MOVBLK TOPCL,TTLCL,BKDX Move block itself
GCLAM4 SUM TTLCL,TTLCL,BKDXU Get to next block
AEQL TTLCL,FRSGPT,GCLAM0 Check for end of region
INCRA GCNO,1 Increment count of regenerations
SETAC NODPCL,0 Permit dump
BKSIZE BKDX,TOPCL Get size of last block
SUM FRSGPT,TOPCL,BKDX Compute new allocation pointer
RESETF FRSGPT,FNC Clear possible function flag
SUBTRT GCGOT,TLSGP1,FRSGPT Compute amount reclaimed
DECRA GCGOT,DESCR
RESETF GCGOT,PTR Clear pointer flag
ACOMP GCREQ,GCGOT,FAIL Compare with amount required
RRTURN GCGOT,2
*_
*---------------------------------------------------------------------*
*
* Block Marking
*
GCM PROC , Procedure to mark blocks
POP BK1CL Restore block to mark from
PUSH ZEROCL Save end marker
GCMA1 GETSIZ BKDX,BK1CL Get size of block
GCMA2 GETD DESCL,BK1CL,BKDX Get descriptor
TESTF DESCL,PTR,GCMA3 Is it a pointer?
AEQLC DESCL,0,,GCMA3 Is address zero?
TOP TOPCL,OFSET,DESCL Get to title of block pointed to
TESTFI TOPCL,MARK,GCMA4 Is block marked?
GCMA3 DECRA BKDX,DESCR Decrement offset
AEQLC BKDX,0,GCMA2 Check for end of block
POP BK1CL Restore block pushed
AEQLC BK1CL,0,,RTN1 Check for end
SETAV BKDX,BK1CL Get size remaining
BRANCH GCMA2 Continue processing
*_
GCMA4 DECRA BKDX,DESCR Decrement offset
AEQLC BKDX,0,,GCMA9 Check for end
SETVA BK1CL,BKDX Insert offset
PUSH BK1CL Save current block
GCMA9 MOVD BK1CL,TOPCL Set poiner to new block
SETFI BK1CL,MARK Mark block
TESTFI BK1CL,STTL,GCMA1 Is it a string?
MOVD BKDX,TWOCL Set size of string to 2
BRANCH GCMA2 Join processing
*_
*---------------------------------------------------------------------*
*
* Procedure to Split Blocks
SPLIT PROC , Procedure to split blocks
POP A4PTR Restore pointer to middle of block
TOP A5PTR,A6PTR,A4PTR Get title and offset
AEQLC A6PTR,0,,RTN1 Avoid block of zero length
GETSIZ A7PTR,A5PTR Get present block size
SUBTRT A7PTR,A7PTR,A6PTR Subtract offset
DECRA A7PTR,DESCR Decrement for title
ACOMPC A7PTR,0,,RTN1,RTN1 Avoid block of zero length
SETSIZ A5PTR,A6PTR Reset size of old block
INCRA A4PTR,DESCR Adjust pointer to middle
PUTDC A4PTR,0,ZEROCL
PUTAC A4PTR,0,A4PTR
SETFI A4PTR,TTL Insert title flag
SETSIZ A4PTR,A7PTR Insert size fo new block
BRANCH RTN1 Return
*_
*---------------------------------------------------------------------*
TITLE 'Compilation Procedures'
*
* Binary Operator Analysis
*
BINOP PROC , Compiler binary operator analysis
RCALL ,FORBLK,,BINOP1 Test for initial blank
AEQLC BRTYPE,NBTYP,RTN2 If so, fail on break
STREAM XSP,TEXTSP,BIOPTB,BINCON
MOVD ZPTR,STYPE Move function descriptor
BRANCH RTZPTR Return function descriptor
*_
BINOP1 RCALL ,FORWRD,,COMP3 If no blank, find character
SELBRA BRTYPE,(,RTN2,RTN2,,,RTN2,RTN2)
BINERR SETAC EMSGCL,ILLBIN Set up error message
BRANCH RTN1 Take error return
*_
BINCON MOVD ZPTR,CONCL No operator, concatenation
BRANCH RTZPTR Return function descriptor
*_
BINEOS SETAC EMSGCL,ILLEOS Set up error message
BRANCH RTN1 Error return
*_
*---------------------------------------------------------------------*
*
* Statement Compilation
*
CMPILE PROC , Procedure to compile statement
SETAC BRTYPE,0 Clear break indicator
MOVD BOSCL,CMOFCL Set statement beginning offset
INCRA CSTNCL,1 Increment statement number
STREAM XSP,TEXTSP,LBLTB,CERR1
* Break out label
LEQLC XSP,0,,CMPILA Check for no label
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,BASECL
* Insert BASE function
SUM CMBSCL,CMBSCL,CMOFCL
* Add offset to base
ACOMP CMBSCL,OCLIM,,,CMPILO
* Check for end of object code
RCALL XCL,BLOCK,CODELT Get block for more
PUTDC CMBSCL,0,GOTGCL Replace BASE with direct goto
PUTDC CMBSCL,DESCR,LIT1CL E3.7.1
PUTDC CMBSCL,2*DESCR,XCL Aim at new block
MOVD CMBSCL,XCL Set up base of new region
SUM OCLIM,CMBSCL,CODELT Compute end of new block
DECRA OCLIM,5*DESCR Leave safety factor
PUTDC CMBSCL,DESCR,BASECL Set BASE function in new region
INCRA CMBSCL,DESCR Increment base
CMPILO SETAC CMOFCL,0 Zero offset
SETAC BOSCL,0 Zero base offset
RCALL LPTR,GENVAR,XSPPTR Get variable for label
AEQLIC LPTR,ATTRIB,0,,CMPILC
* Check for previous definition
AEQLC CNSLCL,0,,CERR2 Check for label redefinition
CMPILC PUTDC LPTR,ATTRIB,CMBSCL Insert label attribute
DEQL LPTR,ENDPTR,,RTN2 Check for END
CMPILA RCALL ,FORBLK,,CERR12 Get to next character
AEQLC BRTYPE,EOSTYP,,RTN3 Was end of statement founc?
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,INITCL
* Insert INIT function
INCRA CMOFCL,DESCR Increment offset
MOVD FRNCL,CMOFCL Save offset for failure position
AEQLC BRTYPE,NBTYP,,CMPSUB
* Check for nonbreak
AEQLC BRTYPE,CLNTYP,CERR3,CMPGO
* Check for goto field
*_
CMPSUB RCALL SUBJND,ELEMNT,,(CDIAG,COMP3)
* Compiler subject
RCALL ,FORBLK,,CERR5 Get to next character
AEQLC BRTYPE,NBTYP,,CMPATN
* Check for nonbreak
AEQLC BRTYPE,EQTYP,,CMPFRM
* Check for assignment
RCALL ,TREPUB,(SUBJND) Copy subject into object code
AEQLC BRTYPE,CLNTYP,,CMPGO
* Check for goto
AEQLC BRTYPE,EOSTYP,CERR5,CMPNGO
* Check for end of statement
*_
CMPATN RCALL PATND,EXPR,,CDIAG Compile pattern
AEQLC BRTYPE,EQTYP,,CMPASP
* Check for replacement
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,SCANCL
* Insert SCAN function
RCALL ,TREPUB,(SUBJND) Copy subject into object code
RCALL ,TREPUB,(PATND) Copy pattern into object code
CMPTGO AEQLC BRTYPE,EOSTYP,,CMPNGO
* Check for end of statement
AEQLC BRTYPE,CLNTYP,CERR5,CMPGO
* Check for end of statement
*_
CMPFRM RCALL FORMND,EXPR,,CDIAG Compile object
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,ASGNCL
* Insert ASGN function
RCALL ,TREPUB,(SUBJND) Copy subject into object code
BRANCH CMPFT Join object publication
*_
CMPASP RCALL FORMND,EXPR,,CDIAG Compile object
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,SJSRCL
* Insert SJSR function
RCALL ,TREPUB,(SUBJND) Copy subject into object code
RCALL ,TREPUB,(PATND) Copy pattern into object code
CMPFT RCALL ,TREPUB,FORMND,CMPTGO
* Copy object into object code
*_
CMPNGO SETVA CSTNCL,CMOFCL Set up offset for failure
PUTD CMBSCL,FRNCL,CSTNCL Insert argument of INIT
BRANCH RTN3 Statement compilation is done
*_ Get to next character
CMPGO RCALL ,FORWRD,,COMP3 Check for end of statement
AEQLC BRTYPE,EOSTYP,,CMPNGO
* Check for nonbreak
AEQLC BRTYPE,NBTYP,CERR11
STREAM XSP,TEXTSP,GOTOTB,CERR11,CERR12
* Analyze goto field
MOVD GOGOCL,GOTLCL Predict GOTL
SETAC GOBRCL,RPTYP Set up predicted closing break
ACOMP STYPE,GTOCL,,CMPGG,CMPGG
* Check for direct goto
MOVD GOGOCL,GOTGCL Set up direct goto
SETAC GOBRCL,RBTYP Set up closing break
CMPGG SELBRA STYPE,(,CMPSGO,CMPFGO,,CMPSGO,CMPFGO)
* Branch on type
CMPUGO SETVA CSTNCL,CMOFCL Set up offset for failure
PUTD CMBSCL,FRNCL,CSTNCL Insert argument of INIT
RCALL GOTOND,EXPR,,CDIAG Compile goto
AEQL BRTYPE,GOBRCL,CERR11
* Verify closing break
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,GOGOCL
* Insert goto function
RCALL ,TREPUB,(GOTOND) Copy goto into object code
RCALL ,FORWRD,,COMP3 Get to next character
AEQLC BRTYPE,EOSTYP,CERR11,RTN3
* Check for end of statement
*_
CMPSGO RCALL SGOND,EXPR,,CDIAG Compile success goto
AEQL BRTYPE,GOBRCL,CERR11
* Verify break character
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,GOGOCL
* Insert goto function
RCALL ,TREPUB,(SGOND) Copy goto into object code
RCALL ,FORWRD,,COMP3 Get to next character
AEQLC BRTYPE,EOSTYP,CMPILL
* Check for end of statement
SETVA CSTNCL,CMOFCL Set up offset for failure
PUTD CMBSCL,FRNCL,CSTNCL Insert argument of INIT
BRANCH RTN3 Compilation is complete, return
*_
CMPILL AEQLC BRTYPE,NBTYP,CERR11 Check for nonbreak
STREAM XSP,TEXTSP,GOTOTB,CERR11,CERR12
* Analyze goto field
AEQLC STYPE,FGOTYP,CMPFTC Check for failure goto
MOVD GOGOCL,GOTLCL Set up goto
SETAC GOBRCL,RPTYP Set up closing break
BRANCH CMPUGO Join processing
*_
CMPFTC AEQLC STYPE,FTOTYP,CERR11 Verify failure goto
MOVD GOGOCL,GOTGCL Set up goto
SETAC GOBRCL,RBTYP Set up closing break
BRANCH CMPUGO Join processing
*_
CMPFGO RCALL FGOND,EXPR,,CDIAG Compile failure goto
AEQL BRTYPE,GOBRCL,CERR11
* Verify failure goto
RCALL ,FORWRD,,COMP3 Get to next character
AEQLC BRTYPE,EOSTYP,CMPILM
* Check for end of statement
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,GOTOCL
* Insert goto function
INCRA CMOFCL,DESCR Increment offset
MOVD SRNCL,CMOFCL Save location for success
SETVA CSTNCL,CMOFCL Set up failure offset
PUTD CMBSCL,FRNCL,CSTNCL Insert argument of INIT
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,GOGOCL
* Insert goto function
RCALL ,TREPUB,(FGOND) Copy goto into object code
PUTD CMBSCL,SRNCL,CMOFCL Insert success offset into code
BRANCH RTN3 Compilation is complete, return
*_
CMPILM AEQLC BRTYPE,NBTYP,CERR11 Verify nonbreak
STREAM XSP,TEXTSP,GOTOTB,CERR11,CERR12
* Analyze goto field
AEQLC STYPE,SGOTYP,CMPSTC Check for success goto
PUSH GOTLCL Save goto type
SETAC GOBRCL,RPTYP Set up closing break
BRANCH CMPILN Join processing
*_
CMPSTC AEQLC STYPE,STOTYP,CERR11 Verify success goto
PUSH GOTGCL Save goto type
SETAC GOBRCL,RBTYP Set up closing break
CMPILN RCALL SGOND,EXPR,,CDIAG Compile success goto
AEQL BRTYPE,GOBRCL,CERR11
* Verify closing break
RCALL ,FORWRD,,COMP3 Get to next character
AEQLC BRTYPE,EOSTYP,CERR11
* Verify end of statement
INCRA CMOFCL,DESCR Increment offset
POP WCL Restore goto type
PUTD CMBSCL,CMOFCL,WCL Insert goto function
RCALL ,TREPUB,(SGOND) Copy goto into object code
SETVA CSTNCL,CMOFCL Set up failure offset
PUTD CMBSCL,FRNCL,CSTNCL Insert argument of INIT
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,GOGOCL
* Insert goto function
RCALL ,TREPUB,(FGOND),RTN3
* Copy goto into object code
*_
CERR1 SETAC EMSGCL,EMSG1 Erroneous label
BRANCH CDIAG
*_
CERR2 SETAC EMSGCL,EMSG2 Multidefined label
BRANCH CDIAG
*_
CERR3 SETAC EMSGCL,EMSG3 Break character before subject
BRANCH CDIAG
*_
CERR5 SETAC EMSGCL,ILLBRK Illegal character after pattern
BRANCH CDIAG
*_
CERR12 SETAC EMSGCL,ILLEOS Illegal statement termination
BRANCH CDIAG
*_
CERR11 SETAC EMSGCL,EMSG14 Characters after goto
CDIAG INCRA BOSCL,DESCR Increment offset of beginning
PUTD CMBSCL,BOSCL,ERORCL Insert ERROR function
INCRA BOSCL,DESCR Increment offset
PUTD CMBSCL,BOSCL,CSTNCL Insert argument of ERROR
MOVD CMOFCL,BOSCL Reposition offset
INCRA ESAICL,DESCR Increment count of errors
ACOMP ESAICL,ESALIM,COMP9 Test for excessive errors
AEQLC LISTCL,0,,CDIAG1 Check for listing mode
MOVD YCL,ERRBAS Set up length of error vector
AEQLC BRTYPE,EOSTYP,,CDIAG3
* Check for end of statement
GETLG XCL,TEXTSP Get length remaining
SUBTRT YCL,YCL,XCL Compute position for marker
CDIAG3 PUTLG ERRSP,YCL Insert length
APDSP ERRSP,QTSP Set in marker
AEQLC BRTYPE,EOSTYP,,CDIAG2
* Check for end of statement
STPRNT IOKEY,OUTBLK,LNBFSP Print statement
CDIAG2 STPRNT IOKEY,OUTBLK,ERRSP Print error marker
PUTLG ERRSP,YCL Insert length in marker
APDSP ERRSP,BLSP Blank out marker
GETSPC TSP,EMSGCL,0 Get error message
SETLC CERRSP,0 Clear specifier
APDSP CERRSP,STARSP Append attention getter
APDSP CERRSP,TSP Append error message
STPRNT IOKEY,OUTBLK,CERRSP Print error message
STPRNT IOKEY,OUTBLK,BLSP Print blank line
CDIAG1 AEQLC UNIT,0,,RTN1 E3.0.1
AEQLC BRTYPE,EOSTYP,,RTN3 E3.0.1
STREAM XSP,TEXTSP,EOSTB,COMP3,,RTN3
* Get to end of statement
DIAGRN STREAD INBFSP,UNIT,DIAGRN,COMP5
* Read card image
SETSP TEXTSP,NEXTSP Set up new line
STREAM XSP,TEXTSP,CARDTB,COMP3,COMP3
* Analyze card type
RCALL ,NEWCRD,,(,,RTN3) Process card image
AEQLC LISTCL,0,,DIAGRN
STPRNT IOKEY,OUTBLK,LNBFSP Print out bypassed card
BRANCH DIAGRN
*_
*---------------------------------------------------------------------*
*
* Element Analysis
*
ELEMNT PROC , Element analysis procedure
RCALL ELEMND,UNOP,,RTN2 Get tree of unary operators
STREAM XSP,TEXTSP,ELEMTB,ELEICH,ELEILI
* Break out element
ELEMN9 SELBRA STYPE,(,ELEILT,ELEVBL,ELENST,ELEFNC,ELEFLT,ELEARY)
* Branch on element type
FSHRTN XSP,1 Delete initial quote
SHORTN XSP,1 Remove terminal quote
RCALL XPTR,GENVAR,(XSPPTR)
* Generate variable for literal
ELEMN5 RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node
PUTDC ELEXND,CODE,LITCL Insert literal function
RCALL ELEYND,BLOCK,CNDSIZ Allocate block for tree node
PUTDC ELEYND,CODE,XPTR Insert literal value
ADDSON ELEXND,ELEYND Add node as son
ELEMN1 AEQLC ELEMND,0,ELEMN6 Check for empty tree
MOVD ZPTR,ELEXND Set up return
BRANCH ELEMRR Join return processing
*_
ELEMN6 ADDSON ELEMND,ELEXND Add as son of present tree
ELEMNR MOVD ZPTR,ELEMND Move tree to return
ELEMRR AEQLIC ZPTR,FATHER,0,,RTZPTR
* Is pointer at top of tree?
GETDC ZPTR,ZPTR,FATHER Move back to father
BRANCH ELEMRR Continue up tree
*_
ELEILT SPCINT XPTR,XSP,ELEINT,ELEMN5
* Convert string to integer
*_
ELEFLT SPREAL XPTR,XSP,ELEDEC,ELEMN5
* Convert string to real
*_
ELEVBL RCALL XPTR,GENVAR,(XSPPTR)
* Generate variable
RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node
PUTDC ELEXND,CODE,XPTR Insert name
BRANCH ELEMN1 Join exit processing
*_
ELENST PUSH ELEMND Save current tree
RCALL ELEXND,EXPR,,RTN1 Evaluate nested expression
POP ELEMND Restore tree
AEQLC BRTYPE,RPTYP,ELECMA,ELEMN1
* Verify right parenthesis
*_
ELEFNC SHORTN XSP,1 Delete open parenthesis
RCALL XPTR,GENVAR,(XSPPTR)
* Generate variable for function name
RCALL XCL,FINDEX,(XPTR) Find function descriptor
RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node
PUTDC ELEXND,CODE,XCL Insert function descriptor in node
AEQLC ELEMND,0,,ELEMN7 Is tree empty?
ADDSON ELEMND,ELEXND Add node as son to tree
ELEMN7 PUSH ELEXND Save current node
RCALL ELEXND,EXPR,,RTN1 Evaluate argument of function
POP ELEMND Resotre current node
ADDSON ELEMND,ELEXND Add argument as son
MOVD ELEMND,ELEXND Move to new node
ELEMN2 AEQLC BRTYPE,RPTYP,,ELEMN3
* Check for left parenthesis
AEQLC BRTYPE,CMATYP,ELECMA
* Verify comma
PUSH ELEMND Save current node
RCALL ELEXND,EXPR,,RTN1 Evaluate next argument
POP ELEMND Restore current node
ADDSIB ELEMND,ELEXND Add argument as sibling
MOVD ELEMND,ELEXND Move to new node
BRANCH ELEMN2 Continue
*_
ELEMN3 GETDC ELEXND,ELEMND,FATHER
* Get father of current node
GETDC XCL,ELEXND,CODE Get function descriptor
GETDC YCL,XCL,0 Get procedure descriptor
TESTF YCL,FNC,,ELEMNR Check for fixed number requirement
SETAV XCL,XCL Get number of arguments given
SETAV YCL,YCL Get number of arguments expected
ELEMN4 ACOMP XCL,YCL,ELEMNR,ELEMNR
* Compare given and expected
RCALL ELEYND,BLOCK,CNDSIZ Allocate block for tree node
PUTDC ELEYND,CODE,LITCL Insert literal function
RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node
PUTDC ELEXND,CODE,NULVCL Insert null string value
ADDSON ELEYND,ELEXND Add null as son of literal
ADDSIB ELEMND,ELEYND Add literal as extra argument
MOVD ELEMND,ELEYND Move to new node
INCRA XCL,1 Increment argument count
BRANCH ELEMN4 Continue
*_
ELEARY SHORTN XSP,1 Remove left bracket
RCALL XPTR,GENVAR,(XSPPTR)
* Generate variable for array or table
RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node
PUTDC ELEXND,CODE,ITEMCL Insert ITEM function
AEQLC ELEMND,0,,ELEMN8 Is tree empty?
ADDSON ELEMND,ELEXND Add as son to tree
ELEMN8 MOVD ELEMND,ELEXND Move to new node
RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node
PUTDC ELEXND,CODE,XPTR Insert array or table name
ADDSON ELEMND,ELEXND Add as son to tree
MOVD ELEMND,ELEXND Move to new node
ELEAR1 PUSH ELEMND Save current node
RCALL ELEXND,EXPR,,RTN1 Evaluate argument
POP ELEMND Restore current node
ADDSIB ELEMND,ELEXND Add as sibling to tree
MOVD ELEMND,ELEXND Move to new node
AEQLC BRTYPE,RBTYP,,ELEMNR
* Check for right bracket
AEQLC BRTYPE,CMATYP,ELECMA,ELEAR1
* Verify comma
*_
ELEICH SETAC EMSGCL,ILCHAR 'ILLEGAL CHARACTER IN ELEMENT'
BRANCH RTN1 Error return
*_
ELEILI AEQLC STYPE,QLITYP,ELEMN9 Check cause of run out
SETAC EMSGCL,OPNLIT 'UNCLOSED LITERAL'
BRANCH RTN1 Error return
*_
ELEINT SETAC EMSGCL,ILLINT 'ILLEGAL INTEGER'
BRANCH RTN1 Error return
*_
ELEDEC SETAC EMSGCL,ILLDEC 'ILLEGAL REAL'
BRANCH RTN1 Error return
*_
ELECMA SETAC EMSGCL,ILLBRK 'ILLEGAL BREAK CHARACTER'
BRANCH RTN1 Error return
*_
*---------------------------------------------------------------------*
*
* Expression Analysis
*
EXPR PROC , Procedure to compile expression
RCALL EXELND,ELEMNT,,(RTN1,EXPNUL)
* Compile element
SETAC EXPRND,0 Zero expression tree
BRANCH EXPR2 Join main processing
*_
EXPR1 PUSH EXPRND Save expression tree
RCALL EXELND,ELEMNT,,(RTN1,EXPERR)
* Compile element
POP EXPRND Restore expression tree
EXPR2 RCALL EXOPCL,BINOP,,(RTN1,EXPR7)
* Get binary operator
RCALL EXOPND,BLOCK,CNDSIZ Allocate block for tree node
PUTDC EXOPND,CODE,EXOPCL Insert binary operator
AEQLC EXPRND,0,EXPR3 Check for empty tree
ADDSON EXOPND,EXELND Add node as son
MOVD EXPRND,EXELND Move to new node
BRANCH EXPR1 Continue processing
*_
EXPR3 GETDC EXOPCL,EXOPCL,2*DESCR
* Get precedence descriptor
SETAV EXOPCL,EXOPCL Get left precedence
GETDC EXEXND,EXPRND,FATHER
* Get father of node
GETDC XPTR,EXEXND,CODE Get function descriptor
GETDC XPTR,XPTR,2*DESCR Get precedence descriptor
ACOMP XPTR,EXOPCL,EXPR4 Compare precedences
ADDSIB EXPRND,EXOPND Add node as sibling
MOVD EXPRND,EXOPND Move to new node
ADDSON EXPRND,EXELND Put current node as son
MOVD EXPRND,EXELND Move to new node
BRANCH EXPR1 Continue processing
*_
EXPR4 ADDSIB EXPRND,EXELND Add current node as sibling
EXPR5 AEQLIC EXPRND,FATHER,0,,EXPR11
* Check for root node
GETDC EXPRND,EXPRND,FATHER
* Get father node
AEQLIC EXPRND,FATHER,0,,EXPR11
* Check for root node
GETDC EXEXND,EXPRND,FATHER
* Get father node
GETDC XPTR,EXEXND,CODE Get function descriptor
GETDC XPTR,XPTR,2*DESCR Get precedence descriptor
ACOMP XPTR,EXOPCL,EXPR5 Compare precedences
INSERT EXPRND,EXOPND Insert node above
BRANCH EXPR1 Continue processing
*_
EXPR7 AEQLC EXPRND,0,EXPR10 Check for empty tree
MOVD XPTR,EXELND Set up for return
BRANCH EXPR9 Join end processing
*_
EXPR10 ADDSIB EXPRND,EXELND Add node as sibling
MOVD XPTR,EXPRND Set up for return
EXPR9 AEQLIC XPTR,FATHER,0,,RTXNAM
* Check for root node
GETDC XPTR,XPTR,FATHER Go back to father
BRANCH EXPR9 Continue up tree
*_
EXPR11 ADDSON EXOPND,EXPRND Add node as son
BRANCH EXPR1 Continue processing
*_
EXPNUL RCALL EXPRND,BLOCK,CNDSIZ Allocate block for tree node
PUTDC EXPRND,CODE,LITCL Insert literal function
RCALL EXEXND,BLOCK,CNDSIZ Allocate block for tree node
PUTDC EXEXND,CODE,NULVCL Insert null string as value
ADDSON EXPRND,EXEXND Add node as son
MOVD XPTR,EXPRND Set up for return
BRANCH RTXNAM
*_
EXPERR SETAC EMSGCL,ILLEOS 'ILLEGAL END OF STATEMENT'
BRANCH RTN1 Take error return
*_
*---------------------------------------------------------------------*
*
* Location of Next Nonblank Character
*
FORWRD PROC , Procedure to get to next character
STREAM XSP,TEXTSP,FRWDTB,COMP3,FORRUN
* Break for next nonblank
FORJRN MOVD BRTYPE,STYPE Set up break type
BRANCH RTN2 Return
*_
FORRUN AEQLC UNIT,0,,FOREOS Check for input stream
AEQLC LISTCL,0,,FORRUR Check listing switch
STPRNT IOKEY,OUTBLK,LNBFSP Print card image
FORRUR STREAD INBFSP,UNIT,FORRUR,COMP5
* Read new card iamge
SETSP TEXTSP,NEXTSP Set up new line
STREAM XSP,TEXTSP,CARDTB,COMP3,COMP3
* Determine card type
RCALL ,NEWCRD,,(FORRUN,FORWRD)
* Process new card
FOREOS MOVD BRTYPE,EOSCL Set up end-of-card
BRANCH RTN2 Return
*_
FORBLK PROC FORWRD Procedure to get to nonblank
STREAM XSP,TEXTSP,IBLKTB,RTN1,FORRUN,FORJRN
* Break out nonblank from blank
*_
*---------------------------------------------------------------------*
*
* Card Image Processing
*
NEWCRD PROC , Process new card image
SELBRA STYPE,(,CMTCRD,CTLCRD,CNTCRD)
* Branch on card type
AEQLC LISTCL,0,,RTN3 Return if listing is off
MOVD XCL,CSTNCL Copy of statement number
INCRA XCL,1 Increment number
INTSPC TSP,XCL Convert it to STRING
AEQLC LLIST,0,CARDL Check for left listing
SETLC RNOSP,0 Clear right specifier
APDSP RNOSP,TSP Set to statement number
BRANCH RTN3
*_
CARDL SETLC LNOSP,0 Clear left specifier
APDSP LNOSP,TSP Set to statement number
BRANCH RTN3
*_
CMTCRD AEQLC LISTCL,0,,RTN1 Return if listing is off
CMTCLR SETLC LNOSP,0 Clear left specifier
SETLC RNOSP,0 Clear right specifier
APDSP LNOSP,BLNSP Blank left specifier
APDSP RNOSP,BLNSP Blank right specifier
BRANCH RTN1
*_
CNTCRD FSHRTN TEXTSP,1 Remove continue character
AEQLC LISTCL,0,,RTN2 Return if listing is off
INTSPC TSP,CSTNCL Get specifier for number
AEQLC LLIST,0,CARDLL Check for left listing
SETLC RNOSP,0 Clear right specifier
APDSP RNOSP,TSP Set to statement number
BRANCH RTN2
*_
CARDLL SETLC LNOSP,0 Clear left specifier
APDSP LNOSP,TSP Set to statement number
BRANCH RTN2
*_
CTLCRD FSHRTN TEXTSP,1 Delete control character
STREAM XSP,TEXTSP,FRWDTB,COMP3,CMTCRD
* Get to next nonblank character
AEQLC STYPE,NBTYP,CMTCRD Verify nonbreak
STREAM XSP,TEXTSP,LBLXTB,CMTCLR,CMTCLR
* Break out command
LEXCMP XSP,UNLSP,CTLCR1,,CTLCR1
* Is it UNLIST?
SETAC LISTCL,0 Zero listing switch
BRANCH RTN1 Return
*_
CTLCR1 LEXCMP XSP,LISTSP,CTLCR3,,CTLCR3
* Is it LIST?
SETAC LISTCL,1 Turn on listing
STREAM XSP,TEXTSP,FRWDTB,COMP3,CMTCLR
* Get to next nonblank character
AEQLC STYPE,NBTYP,CMTCLR Verify nonbreak
STREAM XSP,TEXTSP,LBLXTB,CMTCLR,CMTCLR
* Get type of listing
LEXCMP XSP,LEFTSP,CTLCR2,,CTLCR2
* Is it LEFT?
SETAC LLIST,1 Set left listing switch
BRANCH CMTCLR Join terminal processing
*_
CTLCR2 SETAC LLIST,0 Zero left listing as default
BRANCH CMTCLR Join terminal processing
*_
CTLCR3 LEXCMP XSP,EJCTSP,CMTCLR,,CMTCLR
* Is it EJECT?
AEQLC LISTCL,0,,CMTCLR Skip eject if not listing
OUTPUT OUTPUT,EJECTF Eject page
BRANCH CMTCLR Join terminal processing
*_
*---------------------------------------------------------------------*
*
* Publication of Code Trees
*
TREPUB PROC , Publish code tree
POP YPTR Restore root node
TREPU1 GETDC XPTR,YPTR,CODE Get code descriptor
INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,XPTR Insert code descriptor
SUM ZPTR,CMBSCL,CMOFCL Compute total position
ACOMP ZPTR,OCLIM,TREPU5 Check against limit
TREPU4 AEQLIC YPTR,LSON,0,,TREPU2 Is there a left son?
GETDC YPTR,YPTR,LSON Get left son
BRANCH TREPU1 Continue
*_
TREPU2 AEQLIC YPTR,RSIB,0,,TREPU3 Is there a right sibling?
GETDC YPTR,YPTR,RSIB Get right sibling
BRANCH TREPU1 Continue
*_
TREPU3 AEQLIC YPTR,FATHER,0,,RTN1 Is there a father?
GETDC YPTR,YPTR,FATHER Get father
BRANCH TREPU2 Continue
*_
TREPU5 SUM ZPTR,CMOFCL,CODELT Compute additional to get
SETVC ZPTR,C Insert CODE data type
RCALL XCL,BLOCK,ZPTR Allocate new code block
AEQLC LPTR,0,,TREPU6 Is there a last label?
PUTDC LPTR,ATTRIB,XCL Insert new code position
TREPU6 MOVBLK XCL,CMBSCL,CMOFCL Move old code
PUTDC CMBSCL,DESCR,GOTGCL Insert direct goto
PUTDC CMBSCL,2*DESCR,LIT1CL E3.7.1
* Insert literal function
PUTDC CMBSCL,3*DESCR,XCL Insert pointer to new code
INCRA CMBSCL,3*DESCR Update end pointer
RCALL ,SPLIT,(CMBSCL) Split off old portion
MOVD CMBSCL,XCL Set up new compiler base pointer
SUM OCLIM,CMBSCL,ZPTR Compute new limit
DECRA OCLIM,5*DESCR Leave safety factor
BRANCH TREPU4 Rejoin processing
*_
*---------------------------------------------------------------------*
*
* Unary Operator Analysis
*
UNOP PROC , Unary operator analysis
RCALL ,FORWRD,,COMP3 Get to next nonblank character
SETAC XPTR,0 Zero code tree
AEQLC BRTYPE,NBTYP,RTN1 Verify nonbreak
UNOPA STREAM XSP,TEXTSP,UNOPTB,RTXNAM,RTN1 E3.4.3
* Break out unary operator
RCALL YPTR,BLOCK,CNDSIZ Allocate block for tree node
PUTDC YPTR,CODE,STYPE Insert function descriptor
AEQLC XPTR,0,,UNOPB Is tree empty
ADDSON XPTR,YPTR Add new node as son
UNOPB MOVD XPTR,YPTR Move to new node
BRANCH UNOPA Continue
*_
*---------------------------------------------------------------------*
TITLE 'Interpreter Executive and Control Procedures'
*
* Code Basing
*
BASE PROC , Interpreter code basing procedure
SUM OCBSCL,OCBSCL,OCICL Add offset to base
SETAC OCICL,0 Zero offset
BRANCH RTNUL3
*_
*---------------------------------------------------------------------*
*
* Direct Goto
*
GOTG PROC , :<X>
RCALL OCBSCL,ARGVAL,,INTR5
* Get code pointer
VEQLC OCBSCL,C,INTR4 Must have CODE data type
SETAC OCICL,0 Zero offset
BRANCH RTNUL3
*_
*---------------------------------------------------------------------*
*
* Label Goto
*
GOTL PROC , :(X)
INCRA OCICL,DESCR Increment offset
GETD XPTR,OCBSCL,OCICL Get object code descriptor
TESTF XPTR,FNC,,GOTLC Test for function
GOTLV ACOMPC TRAPCL,0,,GOTLV1,GOTLV1
* Check &TRACE
LOCAPT ATPTR,TLABL,XPTR,GOTLV1
* Look for LABEL trace
PUSH XPTR Save variable
RCALL ,TRPHND,ATPTR E3.3.1
* Perform trace
POP XPTR Restore variable
GOTLV1 DEQL XPTR,RETCL,GOTL1 Compare with RETURN
RRTURN ,6 Return by value
*_
GOTL1 DEQL XPTR,FRETCL,GOTL2 Compare with FRETURN
RRTURN ,4 Fail
*_
GOTL2 DEQL XPTR,NRETCL,GOTL3 Compare with NRETURN
RRTURN ,5 Return by name
*_
GOTL3 GETDC OCBSCL,XPTR,ATTRIB Get object code base
AEQLC OCBSCL,0,,INTR4 Must not be zero
SETAC OCICL,0 Zero offset
BRANCH RTNUL3 Return
*_
GOTLC RCALL XPTR,INVOKE,XPTR,(INTR5,,INTR4) E3.10.3
* Evaluate goto
VEQLC XPTR,S,INTR4,GOTLV Variable must be STRING
*_
*---------------------------------------------------------------------*
*
* Internal Goto
*
GOTO PROC , Interpreter goto procedure
INCRA OCICL,DESCR Increment offset
GETD OCICL,OCBSCL,OCICL Get offset
BRANCH RTNUL3 Return
*_
*---------------------------------------------------------------------*
*
* Statement Initialization
*
INIT PROC , Statement initialization procedure
MOVD LSTNCL,STNOCL Update &LASTNO
INCRA OCICL,DESCR Increment offset
GETD XCL,OCBSCL,OCICL Get statement data
MOVA STNOCL,XCL Update &STNO
SETAV FRTNCL,XCL Set up failure offset
ACOMP EXNOCL,EXLMCL,EXEX,EXEX
* Check &STLIMIT
INCRA EXNOCL,1 Increment &STCOUNT
ACOMPC TRAPCL,0,,RTNUL3,RTNUL3
* Check &TRACE
LOCAPT ATPTR,TKEYL,STCTKY,RTNUL3
RCALL ,TRPHND,ATPTR E3.3.1
* Perform trace
BRANCH RTNUL3
*_
*---------------------------------------------------------------------*
*
* Basic Interpreter Procedure
*
INTERP PROC , Interpreter core procedure
INCRA OCICL,DESCR Increment offset
GETD XPTR,OCBSCL,OCICL Get object code descriptor
TESTF XPTR,FNC,INTERP Test for function
RCALL XPTR,INVOKE,(XPTR),(,INTERP,INTERP,RTN1,RTN2,RTN3)
MOVD OCICL,FRTNCL Set offset for failure
INCRA FALCL,1 Increment &STFCOUNT
ACOMPC TRAPCL,0,,INTERP,INTERP
* Check &TRACE
LOCAPT ATPTR,TKEYL,FALKY,INTERP
RCALL ,TRPHND,ATPTR E3.3.1
* Perform trace
BRANCH INTERP
*_
*---------------------------------------------------------------------*
*
* Procedure Invocation
*
INVOKE PROC , Invokation procedure
POP INCL Get function index
GETDC XPTR,INCL,0 Get procedure descriptor
VEQL INCL,XPTR,INVK2 Check argument counts
INVK1 BRANIC INCL,0 If equal, branch indirect
*_
INVK2 TESTF XPTR,FNC,ARGNER,INVK1
* Check for variable argument number
*_
*---------------------------------------------------------------------*
TITLE 'Argument Evaluation Procedures'
*
* Argument Evaluation
*
ARGVAL PROC , Procedure to evaluate argument
INCRA OCICL,DESCR Increment interpreter offset
GETD XPTR,OCBSCL,OCICL Get argument
TESTF XPTR,FNC,,ARGVC Test for function descriptor
ARGV1 AEQLC INSW,0,,ARGV2 Check &INPUT
LOCAPV ZPTR,INATL,XPTR,ARGV2
* Look for input association
GETDC ZPTR,ZPTR,DESCR Get input descriptor
RCALL XPTR,PUTIN,(ZPTR,XPTR),(FAIL,RTXNAM)
*_
ARGVC RCALL XPTR,INVOKE,(XPTR),(FAIL,ARGV1,RTXNAM)
*_
ARGV2 GETDC XPTR,XPTR,DESCR Get value from name
BRANCH RTXNAM
*_
*---------------------------------------------------------------------*
*
* Evaluation of Unevaluated Expressions
*
EXPVAL PROC , Procedure to evaluate expression
SETAC SCL,1 Note procedure entrance
EXPVJN POP XPTR Restore pointer to object code
EXPVJ2 PUSH (OCBSCL,OCICL,PATBCL,PATICL,WPTR,XCL,YCL,TCL)
PUSH (MAXLEN,LENFCL,PDLPTR,PDLHED,NAMICL,NHEDCL)
* Save system state descriptors
SPUSH (HEADSP,TSP,TXSP,XSP)
* Save system state specifiers
MOVD OCBSCL,XPTR Set up new code base
SETAC OCICL,DESCR Initialize offset
MOVD PDLHED,PDLPTR Set up new history list header
MOVD NHEDCL,NAMICL Set up new name list header
GETD XPTR,OCBSCL,OCICL Get object code descriptor
TESTF XPTR,FNC,,EXPVC Check for function
EXPV11 AEQLC SCL,0,,EXPV6 Check procedure entry
AEQLC INSW,0,,EXPV4 Check &INPUT
LOCAPV ZPTR,INATL,XPTR,EXPV4
* Look for input association
GETDC ZPTR,ZPTR,DESCR Get input association
RCALL XPTR,PUTIN,(ZPTR,XPTR),(EXPV1,EXPV6)
* Perform input
*_
EXPV4 GETDC XPTR,XPTR,DESCR Get value
EXPV6 SETAC SCL,2 Set up exit
BRANCH EXPV7 Join processing
*_
EXPV9 POP SCL Popoff switch
EXPV1 SETAC SCL,1 Set new exit switch
EXPV7 SPOP (XSP,TXSP,TSP,HEADSP)
* Restore system specifiers
POP (NHEDCL,NAMICL,PDLHED,PDLPTR,LENFCL,MAXLEN)
POP (TCL,YCL,XCL,WPTR,PATICL,PATBCL,OCICL,OCBSCL)
* Restore system descriptors
SELBRA SCL,(FAIL,RTXNAM,RTZPTR)
* Select exit
*_
EXPVC PUSH SCL Save entrance indicator
RCALL XPTR,INVOKE,XPTR,(EXPV9,EXPV5,)
* Evaluate function
POP SCL Restore entrance indicator
AEQLC SCL,0,EXPV6 Check entry indicator
SETAC SCL,3 Set exit switch
MOVD ZPTR,XPTR Set up value
BRANCH EXPV7 Join end processing
*_
EXPV5 POP SCL Restore entry indicator
BRANCH EXPV11 Join processing with name
*_
EXPEVL PROC EXPVAL Procedure to get expression value
SETAC SCL,0 Set entry indicator
BRANCH EXPVJN Join processing
*_
EVAL PROC EXPVAL EVAL(X)
RCALL XPTR,ARGVAL,,FAIL Get argument
VEQLC XPTR,E,,EVAL1 Is it EXPRESSION?
VEQLC XPTR,I,,RTXPTR INTEGER is idempotent
VEQLC XPTR,R,,RTXPTR REAL is idempotent
VEQLC XPTR,S,INTR1 Is it STRING?
LOCSP XSP,XPTR Get specifier
LEQLC XSP,0,,RTXPTR E3.1.4
SPCINT XPTR,XSP,,RTXPTR Convert to INTEGER
SPREAL XPTR,XSP,,RTXPTR Convert to REAL
MOVD ZPTR,XPTR Set up to convert to EXPRESSION
RCALL XPTR,CONVE,,(FAIL,INTR10)
* Convert to EXPRESSION
EVAL1 SETAC SCL,0 Set up entry indicator
BRANCH EXPVJ2 Join processing
*_
*---------------------------------------------------------------------*
*
* Evaluation of Integer Argument
*
INTVAL PROC , Integer argument procedure
INCRA OCICL,DESCR Increment offset
GETD XPTR,OCBSCL,OCICL Get object code descriptor
TESTF XPTR,FNC,,INTVC Check for function
INTV1 AEQLC INSW,0,,INTV3 Check &INPUT
LOCAPV ZPTR,INATL,XPTR,INTV3
* Look for input association
GETDC ZPTR,ZPTR,DESCR Get association
RCALL XPTR,PUTIN,(ZPTR,XPTR),FAIL
* Perform input
INTV LOCSP XSP,XPTR Get specifier for string
SPCINT XPTR,XSP,INTR1,RTXNAM
* Convert to integer
*_
INTV3 GETDC XPTR,XPTR,DESCR Get value
INTV2 VEQLC XPTR,I,,RTXNAM INTEGER desired
VEQLC XPTR,S,INTR1,INTV STRING must be converted
*_
INTVC RCALL XPTR,INVOKE,(XPTR),(FAIL,INTV1,INTV2)
*_
*---------------------------------------------------------------------*
*
* Evaluation of Argument as Pattern
*
PATVAL PROC , Evaluate argument as pattern
INCRA OCICL,DESCR Increment offset
GETD XPTR,OCBSCL,OCICL Get object code descriptor
TESTF XPTR,FNC,,PATVC Check for function descriptor
PATV1 AEQLC INSW,0,,PATV2 Check &INPUT
LOCAPV ZPTR,INATL,XPTR,PATV2
* Look for input association
GETDC ZPTR,ZPTR,DESCR Get association
RCALL XPTR,PUTIN,(ZPTR,XPTR),(FAIL,RTXNAM)
* Perform input
*_
PATVC RCALL XPTR,INVOKE,(XPTR),(FAIL,PATV1,PATV3)
* Evaluate argument
*_
PATV2 GETDC XPTR,XPTR,DESCR Get value
PATV3 VEQLC XPTR,P,,RTXNAM Is it PATTERN?
VEQLC XPTR,S,,RTXNAM Is it STRING?
VEQLC XPTR,I,,GENVIX Is it INTEGER?
VEQLC XPTR,R,,PATVR Is it REAL?
VEQLC XPTR,E,INTR1 Is it EXPRESSION?
RCALL TPTR,BLOCK,STARSZ Allocate block for pattern
MOVBLK TPTR,STRPAT,STARSZ Copy pattern for expression
PUTDC TPTR,4*DESCR,XPTR Insert expression
MOVD XPTR,TPTR Set up value
BRANCH RTXNAM Return
*_
PATVR REALST XSP,XPTR Convert REAL to STRING
RCALL XPTR,GENVAR,XSPPTR,RTXNAM
* Generate variable
*_
*---------------------------------------------------------------------*
*
* Evaluation of Argument as String
*
VARVAL PROC , Evaluate argument as string
INCRA OCICL,DESCR Increment offset
GETD XPTR,OCBSCL,OCICL Get object code descriptor
TESTF XPTR,FNC,,VARVC Check for function
VARV1 AEQLC INSW,0,,VARV4 Check &INPUT
LOCAPV ZPTR,INATL,XPTR,VARV4
* Look for input association
GETDC ZPTR,ZPTR,DESCR Get input association
RCALL XPTR,PUTIN,(ZPTR,XPTR),(FAIL,RTXNAM)
* Perform input
*_
VARV4 GETDC XPTR,XPTR,DESCR Get value
VARV2 VEQLC XPTR,S,,RTXNAM Is it STRING?
VEQLC XPTR,I,INTR1,GENVIX Convert INTEGER to STRING
*_
VARVC RCALL XPTR,INVOKE,(XPTR),(FAIL,VARV1,VARV2)
* Evaluate function
*_
*---------------------------------------------------------------------*
*
* Evaluation of Argument Pair
*
XYARGS PROC , Procedure to evaluate argument pair
SETAC SCL,0 Note first argument
XYN INCRA OCICL,DESCR Increment offset
GETD YPTR,OCBSCL,OCICL Get object code descriptor
TESTF YPTR,FNC,,XYC Check for function
XY1 AEQLC INSW,0,,XY2 Check &INPUT
LOCAPV ZPTR,INATL,YPTR,XY2 Look for input association
GETDC ZPTR,ZPTR,DESCR Get input association
RCALL YPTR,PUTIN,(ZPTR,YPTR),FAIL
* Perform input
XY3 AEQLC SCL,0,RTN2 Check for completion
SETAC SCL,1 Note seconf argument
MOVD XPTR,YPTR Set up first argument
BRANCH XYN Go around again
*_
XY2 GETDC YPTR,YPTR,DESCR Get value
BRANCH XY3 Continue
*_
XYC PUSH (SCL,XPTR) Save indicator and argument
RCALL YPTR,INVOKE,(YPTR),(FAIL,XY4)
* Evaluate function
POP (XPTR,SCL) Restore indicator and argument
BRANCH XY3 Join processing
*_
XY4 POP (XPTR,SCL) Restore indicator and argument
BRANCH XY1 Join processing
*_
*---------------------------------------------------------------------*
TITLE 'Arithmetic Operations, Predicates, and Functions'
ADD PROC , X + Y
SETAC SCL,1
BRANCH ARITH
*_
DIV PROC ADD X / Y
SETAC SCL,2
BRANCH ARITH
*_
EXP PROC ADD X ** Y and X ^ Y
SETAC SCL,3
BRANCH ARITH
*_
MPY PROC ADD X * Y
SETAC SCL,4
BRANCH ARITH
*_
SUB PROC ADD X - Y
SETAC SCL,5
BRANCH ARITH
*_
EQ PROC ADD EQ(X,Y)
SETAC SCL,6
BRANCH ARITH
*_
GE PROC ADD GE(X,Y)
SETAC SCL,7
BRANCH ARITH
*_
GT PROC ADD GT(X,Y)
SETAC SCL,8
BRANCH ARITH
*_
LE PROC ADD LE(X,Y)
SETAC SCL,9
BRANCH ARITH
*_
LT PROC ADD LT(X,Y)
SETAC SCL,10
BRANCH ARITH
*_
NE PROC ADD NE(X,Y)
SETAC SCL,11
BRANCH ARITH
*_
REMDR PROC ADD REMDR(X,Y)
SETAC SCL,12
BRANCH ARITH
*_
ARITH PUSH SCL Save procedure switch
RCALL ,XYARGS,,FAIL Evaluate arguments
POP SCL Restore procedure switch
SETAV DTCL,XPTR Set up data type pair
MOVV DTCL,YPTR
DEQL DTCL,IIDTP,,ARTHII INTEGER-INTEGER
DEQL DTCL,IVDTP,,ARTHIV INTEGER-STRING
DEQL DTCL,VIDTP,,ARTHVI STRING-INTEGER
DEQL DTCL,VVDTP,,ARTHVV STRING-STRING
DEQL DTCL,RRDTP,,ARTHRR REAL-REAL
DEQL DTCL,IRDTP,,ARTHIR INTEGER-REAL
DEQL DTCL,RIDTP,,ARTHRI REAL-INTEGER
DEQL DTCL,VRDTP,,ARTHVR STRING-REAL
DEQL DTCL,RVDTP,INTR1,ARTHRV
* REAL-STRING
*_
ARTHII SELBRA SCL,(AD,DV,EX,MP,SB,CEQ,CGE,CGT,CLE,CLT,CNE,RM)
*_
ARTHVI LOCSP XSP,XPTR Get specifier
SPCINT XPTR,XSP,,ARTHII Convert string to integer
SPREAL XPTR,XSP,INTR1,ARTHRI
* Convert to real if possible
*_
ARTHIV LOCSP YSP,YPTR Get specifier
SPCINT YPTR,YSP,,ARTHII Convert string to integer
SPREAL YPTR,YSP,INTR1,ARTHIR
* Convert to real if possible
*_
ARTHVV LOCSP XSP,XPTR Get specifier
SPCINT XPTR,XSP,,ARTHIV Convert string to integer
SPREAL XPTR,XSP,INTR1,ARTHRV
* Convert to real if possible
*_
ARTHRR SELBRA SCL,(AR,DR,EXR,MR,SR,REQ,RGE,RGT,RLE,RLT,RNE,INTR1)
*_
ARTHIR INTRL XPTR,XPTR Convert integer to real
BRANCH ARTHRR
*_
ARTHRI INTRL YPTR,YPTR Convert integer to real
BRANCH ARTHRR
*_
ARTHVR LOCSP XSP,XPTR Get spedifier
SPCINT XPTR,XSP,,ARTHIR Convert string to integer
SPREAL XPTR,XSP,INTR1,ARTHRR
* Convert to real if possible
*_
ARTHRV LOCSP YSP,YPTR
SPCINT YPTR,YSP,,ARTHRI Convert string to integer
SPREAL YPTR,YSP,INTR1,ARTHRR
* Convert to real if possible
*_
AD SUM ZPTR,XPTR,YPTR,AERROR,ARTN
*_
DV DIVIDE ZPTR,XPTR,YPTR,AERROR,ARTN
*_
EX EXPINT ZPTR,XPTR,YPTR,AERROR,ARTN
*_
MP MULT ZPTR,XPTR,YPTR,AERROR,ARTN
*_
SB SUBTRT ZPTR,XPTR,YPTR,AERROR,ARTN
*_
CEQ AEQL XPTR,YPTR,FAIL,RETNUL
*_
CGE ACOMP XPTR,YPTR,RETNUL,RETNUL,FAIL
*_
CGT ACOMP XPTR,YPTR,RETNUL,FAIL,FAIL
*_
CLE ACOMP XPTR,YPTR,FAIL,RETNUL,RETNUL
*_
CLT ACOMP XPTR,YPTR,FAIL,FAIL,RETNUL
*_
CNE AEQL XPTR,YPTR,RETNUL,FAIL
*_
AR ADREAL ZPTR,XPTR,YPTR,AERROR,ARTN
*_
DR DVREAL ZPTR,XPTR,YPTR,AERROR,ARTN
*_
EXR EXREAL ZPTR,XPTR,YPTR,AERROR,ARTN
*_
MR MPREAL ZPTR,XPTR,YPTR,AERROR,ARTN
*_
SR SBREAL ZPTR,XPTR,YPTR,AERROR,ARTN
*_
REQ RCOMP XPTR,YPTR,FAIL,RETNUL,FAIL
*_
RGE RCOMP XPTR,YPTR,RETNUL,RETNUL,FAIL
*_
RGT RCOMP XPTR,YPTR,RETNUL,FAIL,FAIL
*_
RLE RCOMP XPTR,YPTR,FAIL,RETNUL,RETNUL
*_
RLT RCOMP XPTR,YPTR,FAIL,FAIL,RETNUL
*_
RNE RCOMP XPTR,YPTR,RETNUL,FAIL,RETNUL
*_
RM DIVIDE ZPTR,XPTR,YPTR,AERROR
* First divide
MULT WPTR,ZPTR,YPTR Multiply truncated part
SUBTRT ZPTR,XPTR,WPTR Get difference
BRANCH ARTN
*_
*---------------------------------------------------------------------*
*
* INTEGER(X)
*
INTGER PROC , INTEGER(X)
RCALL XPTR,ARGVAL,,FAIL Get argument
VEQLC XPTR,I,,RETNUL INTEGER succeeds
VEQLC XPTR,S,FAIL STRING must be checked
LOCSP XSP,XPTR Get specifier
SPCINT XPTR,XSP,FAIL,RETNUL
* Try conversion to INTEGER
*_
*---------------------------------------------------------------------*
*
* Arithmetic Negative
*
MNS PROC , -X
RCALL XPTR,ARGVAL,,FAIL Get argument
VEQLC XPTR,I,,MNSM INTEGER acceptable
VEQLC XPTR,S,,MNSV STRING must be converted
VEQLC XPTR,R,INTR1,MNSR REAL is acceptable
*_
MNSM MNSINT ZPTR,XPTR,AERROR,ARTN
* Form negative of integer
*_
MNSV LOCSP XSP,XPTR Get specifier for string
SPCINT XPTR,XSP,,MNSM Convert to INTEGER
SPREAL XPTR,XSP,INTR1 Convert to REAL
MNSR MNREAL ZPTR,XPTR Form negative of real
BRANCH ARTN
*_
*---------------------------------------------------------------------*
*
* Unary Plus Operator
*
PLS PROC , +X
RCALL ZPTR,ARGVAL,,FAIL Get argument
VEQLC ZPTR,I,,ARTN Is it INTEGER?
VEQLC ZPTR,S,,PLSV Is it STRING?
VEQLC ZPTR,R,INTR1,ARTN Is it REAL?
*_
PLSV LOCSP XSP,ZPTR Get specifier
SPCINT ZPTR,XSP,,ARTN Convert STRING to INTEGER
SPREAL ZPTR,XSP,INTR1,ARTN Convert STRING to REAL
*_
*---------------------------------------------------------------------*
TITLE 'Pattern-valued Functions and Operations'
ANY PROC , ANY(S)
PUSH ANYCCL Save function descriptor
BRANCH CHARZ Join common processing
*_
BREAK PROC ANY BREAK(S)
PUSH BRKCCL Save function descriptor
PUSH ZEROCL Save minimum length of zero
BRANCH ABNSND Join common processing
*_
NOTANY PROC ANY NOTANY(S)
PUSH NNYCCL Save function descriptor
BRANCH CHARZ
*_
SPAN PROC ANY SPAN(S)
PUSH SPNCCL Save function descriptor
CHARZ PUSH CHARCL Save minimum length of one
ABNSND RCALL XPTR,ARGVAL,,FAIL Evaluate argument
POP (ZCL,YCL) Restore descriptor and length
VEQLC XPTR,S,,PATNOD STRING is acceptable argument
VEQLC XPTR,E,,PATNOD So is EXPRESSION
VEQLC XPTR,I,INTR1 INTEGER must be converted
RCALL XPTR,GNVARI,XPTR
PATNOD DEQL XPTR,NULVCL,,NONAME E3.5.4
RCALL TPTR,BLOCK,LNODSZ E3.5.4
MAKNOD ZPTR,TPTR,ZCL,ZEROCL,YCL,XPTR
* Construct the pattern
BRANCH RTZPTR
*_
LEN PROC ANY LEN(N)
PUSH LNTHCL Save function descriptor
BRANCH LPRTND
*_
POS PROC ANY POS(N)
PUSH POSICL Save function descriptor
BRANCH LPRTND
*_
RPOS PROC ANY RPOS(N)
PUSH RPSICL Save function descriptor
BRANCH LPRTND
*_
RTAB PROC ANY RTAB(N)
PUSH RTBCL Save function descriptor
BRANCH LPRTND
*_
TAB PROC ANY TAB(N)
PUSH TBCL Save function descriptor
LPRTND RCALL XPTR,ARGVAL,,FAIL Evaluate argument
POP YCL Restore function descriptor
MOVD ZCL,ZEROCL Predict minimum length of zero
VEQLC XPTR,I,,LPRTNI If INTEGER check for LEN
VEQLC XPTR,E,,PATNOD EXPRESSION is acceptable
VEQLC XPTR,S,INTR1 STRING must be converted to INTEGER
LOCSP ZSP,XPTR Get specifier
SPCINT XPTR,ZSP,INTR1 Convert to INTEGER
LPRTNI ACOMPC XPTR,0,,,LENERR E3.6.1
DEQL YCL,LNTHCL,PATNOD E3.6.1
MOVA ZCL,XPTR If so, use value of integer
BRANCH PATNOD Go form pattern
*_
*---------------------------------------------------------------------*
*
* ARBNO(P)
*
ARBNO PROC , ARBNO(P)
RCALL XPTR,PATVAL,,FAIL Evaluate argument as pattern
VEQLC XPTR,P,,ARBP PATTERN is desired form
VEQLC XPTR,S,INTR1 STRING must be made into PATTERN
LOCSP TSP,XPTR Get specifier
GETLG TMVAL,TSP Get length of string
RCALL TPTR,BLOCK,LNODSZ Allocate block for argument
MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR
ARBP GETSIZ XSIZ,XPTR Get size of pattern
SUM TSIZ,XSIZ,ARBSIZ Add additional space for ARBNO node
SETVC TSIZ,P Insert PATTERN data type
RCALL TPTR,BLOCK,TSIZ Allocate block for pattern
MOVD ZPTR,TPTR Save pointer to return
GETSIZ TSIZ,ARHEAD Set up copy for heading node
CPYPAT TPTR,ARHEAD,ZEROCL,ZEROCL,ZEROCL,TSIZ
SUM ZSIZ,XSIZ,TSIZ
CPYPAT TPTR,XPTR,ZEROCL,TSIZ,ZSIZ,XSIZ
SUM TSIZ,NODSIZ,NODSIZ Set up size for trailing node
CPYPAT TPTR,ARTAIL,ZEROCL,ZSIZ,ZEROCL,TSIZ
SUM ZSIZ,TSIZ,ZSIZ Set up size for backup node
CPYPAT TPTR,ARBACK,ZEROCL,ZSIZ,TSIZ,TSIZ
BRANCH RTZPTR
*_
*---------------------------------------------------------------------*
*
* @X
*
ATOP PROC , @X
INCRA OCICL,DESCR Increment interpreter offset
GETD YPTR,OCBSCL,OCICL Get object code descriptor
TESTF YPTR,FNC,ATOP1 Test for function descriptor
RCALL YPTR,INVOKE,YPTR,(FAIL,ATOP1,)
VEQLC YPTR,E,NEMO Only EXPRESSION can be value
ATOP1 RCALL TPTR,BLOCK,LNODSZ Allocate pattern node
MAKNOD ZPTR,TPTR,ZEROCL,ZEROCL,ATOPCL,YPTR
BRANCH RTZPTR
*_
*---------------------------------------------------------------------*
*
* Value Assignment Operators
*
NAM PROC , X . Y
PUSH ENMECL Save function descriptor
BRANCH NAM5 Join processing
*_
DOL PROC NAM X $ Y
PUSH ENMICL Save function descritpor
NAM5 RCALL XPTR,PATVAL,,FAIL Get pattern for first argument
INCRA OCICL,DESCR Increment offset
GETD YPTR,OCBSCL,OCICL Get object code descriptor
TESTF YPTR,FNC,,NAMC2 Check for function
NAM3 VEQLC XPTR,S,,NAMV Is first argument STRING?
VEQLC XPTR,P,INTR1,NAMP Is it PATTERN?
*_
NAMC2 PUSH XPTR Save first argument
RCALL YPTR,INVOKE,YPTR,(FAIL,NAM4,)
* Evaluate second argument
VEQLC YPTR,E,NEMO Verify EXPRESSION
NAM4 POP XPTR Restore first argument
BRANCH NAM3 Join processing
*_
NAMV LOCSP TSP,XPTR Get specifier
GETLG TMVAL,TSP Get length
RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern
MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR
* Make pattern node
NAMP RCALL TPTR,BLOCK,SNODSZ Allocate block for pattern
MAKNOD WPTR,TPTR,ZEROCL,ZEROCL,NMECL
* Make node for naming
RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern
POP TVAL Restore function descriptor
MAKNOD YPTR,TPTR,ZEROCL,ZEROCL,TVAL,YPTR
* Make pattern for backup
GETSIZ XSIZ,XPTR Get size of first pattern
SUM YSIZ,XSIZ,NODSIZ Compute total size
GETSIZ TSIZ,YPTR Get size of naming node
SUM ZSIZ,YSIZ,TSIZ Compute total
SETVC ZSIZ,P Insert PATTERN data type
RCALL TPTR,BLOCK,ZSIZ Allocate block for total pattern
MOVD ZPTR,TPTR Save copy
LVALUE TVAL,XPTR Get least value
CPYPAT TPTR,WPTR,TVAL,ZEROCL,NODSIZ,NODSIZ
* Copy three patterns
CPYPAT TPTR,XPTR,ZEROCL,NODSIZ,YSIZ,XSIZ
CPYPAT TPTR,YPTR,ZEROCL,YSIZ,ZEROCL,TSIZ
BRANCH RTZPTR Return pattern as value
*_
*---------------------------------------------------------------------*
*
* Binary Alternation Operator
*
OR PROC , X | Y
RCALL XPTR,PATVAL,,FAIL Get first argument
PUSH XPTR Save first argument
RCALL YPTR,PATVAL,,FAIL Get second argument
POP XPTR Restore first argument
SETAV DTCL,XPTR Get first data type
MOVV DTCL,YPTR Insert second data type
DEQL DTCL,VVDTP,,ORVV Is it STRING-STRING?
DEQL DTCL,VPDTP,,ORVP Is it STRING-PATTERN?
DEQL DTCL,PVDTP,,ORPV Is it PATTERN-STRING?
DEQL DTCL,PPDTP,INTR1,ORPP
* Is it PATTERN_PATTERN?
*_
ORVV LOCSP XSP,XPTR Get specifier
GETLG TMVAL,XSP Get length
RCALL TPTR,BLOCK,LNODSZ Get block for pattern
MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR
* Construct pattern
ORPV LOCSP YSP,YPTR Get specifier
GETLG TMVAL,YSP Get length
RCALL TPTR,BLOCK,LNODSZ Get block for pattern
MAKNOD YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR
* Construct pattern
ORPP GETSIZ XSIZ,XPTR Get size of first pattern
GETSIZ YSIZ,YPTR Get size of second pattern
SUM TSIZ,XSIZ,YSIZ Compute total size
SETVC TSIZ,P Insert PATTERN data type
RCALL TPTR,BLOCK,TSIZ Allocate block for pattern
MOVD ZPTR,TPTR Save copy
CPYPAT TPTR,XPTR,ZEROCL,ZEROCL,ZEROCL,XSIZ
* Copy first pattern
CPYPAT TPTR,YPTR,ZEROCL,XSIZ,ZEROCL,YSIZ
* Copy second pattern
LINKOR ZPTR,XSIZ Link alternatives
BRANCH RTZPTR Return pattern as value
*_
ORVP LOCSP XSP,XPTR Get specifier
GETLG TMVAL,XSP Get length
RCALL TPTR,BLOCK,LNODSZ Get block for pattern
MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR
* Construct pattern
BRANCH ORPP Join processing
*_
*---------------------------------------------------------------------*
TITLE 'Pattern Matching Procedures'
*
* Simple Pattern Matching
*
SCAN PROC , Pattern Matching
RCALL XPTR,ARGVAL,,FAIL Get subject
PUSH XPTR Save subject
RCALL YPTR,PATVAL,,FAIL Get pattern
POP XPTR Restore subject
SETAV DTCL,XPTR Set up data type pair
MOVV DTCL,YPTR
INCRA SCNCL,1 Increment count of scanner entries
DEQL DTCL,VVDTP,,SCANVV Is it STRING-STRING?
DEQL DTCL,VPDTP,,SCANVP Is it STRING-PATTERN?
DEQL DTCL,IVDTP,,SCANIV Is it INTEGER-STRING?
DEQL DTCL,RVDTP,,SCANRV Is it REAL-STRING?
DEQL DTCL,RPDTP,,SCANRP Is it REAL-PATTERN?
DEQL DTCL,IPDTP,INTR1,SCANIP
* Is it INTEGER-PATTERN?
*_
SCANVV LOCSP XSP,XPTR Get specifier for subject
LOCSP YSP,YPTR Get specifier for pattern
SCANVB SUBSP TSP,YSP,XSP,FAIL Get part to compare
LEXCMP TSP,YSP,,RETNUL Compare strings
AEQLC ANCCL,0,FAIL Check &ANCHOR
FSHRTN XSP,1 Delete lead character
BRANCH SCANVB Try again
*_
SCANIV RCALL XPTR,GNVARI,XPTR Generate variable for integer
BRANCH SCANVV Join processing
*_
SCANVP LOCSP XSP,XPTR Get specifier for subject
RCALL ,SCNR,,(FAIL,,FAIL) Call scanner
RCALL ,NMD,,(FAIL,RTN2) Perform naming
*_
SCANIP RCALL XPTR,GNVARI,XPTR Generate variable for integer
BRANCH SCANVP Join processing
*_
SCANRV REALST XSP,XPTR Convert REAL to STRING
RCALL XPTR,GENVAR,XSPPTR,SCANVV
*_
SCANRP REALST XSP,XPTR Convert REAL to STRING
RCALL XPTR,GENVAR,XSPPTR,SCANVP
* Generate variable
*_
*_
*---------------------------------------------------------------------*
*
* Pattern Matching with Replacement
*
SJSR PROC , Pattern matching with replacement
INCRA OCICL,DESCR Increment offset
GETD WPTR,OCBSCL,OCICL Get object code descriptor
TESTF WPTR,FNC,,SJSRC1 Check for function
SJSR1 AEQLC INSW,0,,SJSR1A Check &INPUT
LOCAPV ZPTR,INATL,WPTR,SJSR1A
* Look of input association
GETDC ZPTR,ZPTR,DESCR Get association
RCALL XPTR,PUTIN,(ZPTR,WPTR),(FAIL,SJSR1B)
* Perform input
*_
SJSR1A GETDC XPTR,WPTR,DESCR Get value
SJSR1B PUSH (WPTR,XPTR) Save name and value
RCALL YPTR,PATVAL,,FAIL Get pattern
POP XPTR Restore value
SETAV DTCL,XPTR Set up data type pair
MOVV DTCL,YPTR
INCRA SCNCL,1 Increment count of scanner calls
DEQL DTCL,VVDTP,,SJSSVV Is it STRING-PATTERN?
DEQL DTCL,VPDTP,,SJSSVP Is it INTEGER-STRING?
DEQL DTCL,IVDTP,,SJSSIV Is it INTEGER-PATTERN?
DEQL DTCL,RVDTP,,SJSSRV Is it REAL-STRING?
DEQL DTCL,RPDTP,,SJSSRP Is it REAL-PATTERN?
DEQL DTCL,IPDTP,INTR1,SJSSIP
*_
SJSRC1 RCALL WPTR,INVOKE,(WPTR),(FAIL,SJSR1,NEMO)
* Evaluate subject
*_
SJSSVP LOCSP XSP,XPTR Get specifier
RCALL ,SCNR,,(FAIL,,FAIL) Call scanner
SETAC NAMGCL,1 Set naming switch
REMSP TAILSP,XSP,TXSP Get tail of subject
BRANCH SJSS1 Join common processing
*_
SJSSIP RCALL XPTR,GNVARI,XPTR Generate STRING from INTEGER
BRANCH SJSSVP Join common processing
*_
SJSSIV RCALL XPTR,GNVARI,XPTR Generate STRING from INTEGER
BRANCH SJSSVV Join common processing
*_
SJSSRV REALST XSP,XPTR Convert REAL to STRING
RCALL XPTR,GENVAR,XSPPTR,SJSSVV
* Generate variable
*_
SJSSRP REALST XSP,XPTR Convert REAL to STRING
RCALL XPTR,GENVAR,XSPPTR,SJSSVP
* Generate variable
*_
SJVVON AEQLC ANCCL,0,FAIL Check &ANCHOR
ADDLG HEADSP,ONECL Increment length of head
FSHRTN XSP,1 Delete head character
BRANCH SJSSV2 Join common processing
*_
SJSSVV LOCSP XSP,XPTR Get specifier for subject
LOCSP YSP,YPTR Get specifier for pattern
SETSP HEADSP,XSP Set up head specifier
SETLC HEADSP,0 Initialize zero length
SJSSV2 SUBSP TSP,YSP,XSP,FAIL Get common length
LEXCMP TSP,YSP,SJVVON,,SJVVON
* Compare strings
SETAC NAMGCL,0 Clear naming switch
REMSP TAILSP,XSP,TSP Get tail of subject
SJSS1 SPUSH (TAILSP,HEADSP) Save head and tail
AEQLC NAMGCL,0,,SJSS1A Check naming switch
RCALL ,NMD,,FAIL Perform naming
SJSS1A RCALL ZPTR,ARGVAL,,FAIL Get object
SPOP (HEADSP,TAILSP) Restore head and tail
POP WPTR Restore name of subject
LEQLC HEADSP,0,SJSSDT Check for null head
LEQLC TAILSP,0,,SJSRV1 Check for null tail
SJSSDT VEQLC ZPTR,S,,SJSRV Is object STRING?
VEQLC ZPTR,P,,SJSRP Is object PATTERN?
VEQLC ZPTR,I,,SJSRI Is object INTEGER?
VEQLC ZPTR,R,,SJSRR Is object REAL?
VEQLC ZPTR,E,INTR1 Is object EXPRESSION?
RCALL TPTR,BLOCK,STARSZ Allocate block for pattern
MOVBLK TPTR,STRPAT,STARSZ Set up pattern for expression
PUTDC TPTR,4*DESCR,ZPTR Insert object
MOVD ZPTR,TPTR Set up converted value
SJSRP SETSP XSP,HEADSP Copy specifier
RCALL XPTR,GENVAR,(XSPPTR)
* Generate variable for head
GETLG TMVAL,HEADSP Get length of head
RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern
MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR
* Make pattern node
SETSP YSP,TAILSP Set up tail specifier
RCALL YPTR,GENVAR,(YSPPTR)
* Generate variable for tail
GETLG TMVAL,TAILSP Get length of tail
RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern
MAKNOD YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR
* Make pattern node
GETSIZ XSIZ,XPTR Get size of head node
GETSIZ YSIZ,YPTR Get size of tail node
GETSIZ ZSIZ,ZPTR Get size of object
SUM TSIZ,XSIZ,ZSIZ Compute total size
SUM TSIZ,TSIZ,YSIZ Get size of new pattern
SETVC TSIZ,P Insert PATTERN data type
RCALL TPTR,BLOCK,TSIZ Allocate block for total pattern
MOVD VVAL,TPTR Get working copy
LVALUE TVAL,ZPTR Get least value of replacement
CPYPAT TPTR,XPTR,TVAL,ZEROCL,XSIZ,XSIZ
* Copy in head
LVALUE TVAL,YPTR Get least value of tail
SUM TSIZ,XSIZ,ZSIZ Get size of first two
CPYPAT TPTR,ZPTR,TVAL,XSIZ,TSIZ,ZSIZ
* Copy in object
CPYPAT TPTR,YPTR,ZEROCL,TSIZ,ZEROCL,YSIZ
* Copy in tail
MOVD ZPTR,VVAL Set up return value
BRANCH SJSRV1 Join common processing
*_
SJSRV LOCSP ZSP,ZPTR
SJSRS GETLG XPTR,TAILSP Get length of tail
GETLG YPTR,HEADSP Get length of tail
GETLG ZPTR,ZSP Get length of object
SUM XPTR,XPTR,YPTR Compute total length
SUM XPTR,XPTR,ZPTR
ACOMP XPTR,MLENCL,INTR8 Check &MAXLNGTH
RCALL ZPTR,CONVAR,(XPTR) Allocate storage for string
LOCSP TSP,ZPTR Get specifier
SETLC TSP,0 Clear length
APDSP TSP,HEADSP Append head
APDSP TSP,ZSP Append object
APDSP TSP,TAILSP Append tail
RCALL ZPTR,GNVARS,XPTR Enter string into storage
SJSRV1 PUTDC WPTR,DESCR,ZPTR Assign value to subject name
AEQLC OUTSW,0,,SJSRV2 Check &OUTPUT
LOCAPV YPTR,OUTATL,WPTR,SJSRV2
* Look for output association
GETDC YPTR,YPTR,DESCR Get output association
RCALL ,PUTOUT,(YPTR,ZPTR) Perform output
SJSRV2 ACOMPC TRAPCL,0,,RTN3,RTN3 Check &TRACE
LOCAPT ATPTR,TVALL,WPTR,RTN3
* Look for VALUE trace
RCALL ,TRPHND,ATPTR,RTN3 E3.3.1
* Perform trace
*_
SJSRI INTSPC ZSP,ZPTR Convert INTEGER
BRANCH SJSRS
*_
SJSRR REALST ZSP,ZPTR Convert REAL
BRANCH SJSRS
*_
*---------------------------------------------------------------------*
*
* Basic Scanning Procedure
*
SCNR PROC , Scanning procedure
GETLG MAXLEN,XSP Get maximum length
LVALUE YSIZ,YPTR Get least value
AEQLC FULLCL,0,SCNR1 Check &FULLSCAN
ACOMP YSIZ,MAXLEN,FAIL CHeck maximum against minimum
SCNR1 SETSP TXSP,XSP Set up working specifier for head
SETLC TXSP,0 Zero length
MOVD PDLPTR,PDLHED Initialize history list
MOVD NAMICL,NHEDCL Initialize name list
AEQLC ANCCL,0,SCNR3 Check &ANCHOR
AEQLC FULLCL,0,,SCNR4 Check &FULLSCAN
MOVD YSIZ,MAXLEN Set up length
BRANCH SCNR5 Join processing
*_
SCNR4 SUBTRT YSIZ,MAXLEN,YSIZ Get difference of lengths
SCNR5 SUM YSIZ,YSIZ,CHARCL Add one
SCNR2 PUSH (YPTR,YSIZ) Save pattern and length
SETSP HEADSP,TXSP Set up head specifier
INCRA PDLPTR,3*DESCR Make room for history entry
ACOMP PDLPTR,PDLEND,INTR31
* Check for overflow
SETAC LENFCL,1 Set length failure
PUTDC PDLPTR,DESCR,SCONCL Insert scan function
GETLG TMVAL,TXSP Get cursor position
PUTDC PDLPTR,2*DESCR,TMVAL
* Insert on history list
PUTDC PDLPTR,3*DESCR,LENFCL
* Insert length failure
BRANCH SCIN1 Join common scanning
*_
SCNR3 INCRA PDLPTR,3*DESCR Make room for history entry
ACOMP PDLPTR,PDLEND,INTR31
* Check for overflow
SETLC HEADSP,0 Zero length of head
PUTDC PDLPTR,DESCR,SCFLCL Insert scan failure function
GETLG TMVAL,TXSP Get cursor position
PUTDC PDLPTR,2*DESCR,TMVAL
* Insert on history list
PUTDC PDLPTR,3*DESCR,LENFCL
* Insert length failure
BRANCH SCIN1 Join common scanning
*_
SCIN PROC SCNR
SCIN1 MOVD PATBCL,YPTR Set up pattern base pointer
SETAC PATICL,0 Zero offset
SCIN2 SETAC LENFCL,1 Set length failure
SCIN3 INCRA PATICL,DESCR Increment offset
GETD ZCL,PATBCL,PATICL Get function descriptor
INCRA PATICL,DESCR Increment offset
GETD XCL,PATBCL,PATICL Get then-or descriptor
INCRA PATICL,DESCR Increment offset
GETD YCL,PATBCL,PATICL Get value-residual descriptor
INCRA PDLPTR,3*DESCR Make room for history entry
ACOMP PDLPTR,PDLEND,INTR31
* Check for overflow
PUTDC PDLPTR,DESCR,XCL Insert then-or descriptor
GETLG TMVAL,TXSP Get cursor position
MOVV TMVAL,YCL Insert residual
PUTDC PDLPTR,2*DESCR,TMVAL
* Insert on history list
PUTDC PDLPTR,3*DESCR,LENFCL
* Insert length failure
AEQLC FULLCL,0,SCIN4 Check &FULLSCAN
CHKVAL MAXLEN,YCL,TXSP,SALT1
* Check values
SCIN4 BRANIC ZCL,0 Branch to procedure
*_
SALF PROC SCNR Nonlength failure procedure
SALF1 SETAC LENFCL,0 Clear length failure
BRANCH SALT2 Join common processing
*_
SALT PROC SCNR Length failure procedure
SALT1 GETDC LENFCL,PDLPTR,3*DESCR
* Get length failure from history
SALT2 GETDC XCL,PDLPTR,DESCR Get then-or descriptor
GETDC YCL,PDLPTR,2*DESCR Get value-residual
DECRA PDLPTR,3*DESCR Back over history entry
MOVD PATICL,XCL Set offset to OR link
AEQLC PATICL,0,,SALT3 Check for none
PUTLG TXSP,YCL Insert old length of head
TESTF PATICL,FNC,SCIN3 Check for function
BRANIC PATICL,0 Branch to procedure
*_
SALT3 AEQLC LENFCL,0,SALT1 Check length failure
BRANCH SALF1 Go to nonlength failure
*_
SCOK PROC SCNR Successful scanning procedure
SETAV PATICL,XCL Set offset from THEN link
AEQLC PATICL,0,SCIN2,RTN2 Check for none
*_
SCON PROC SCNR
AEQLC FULLCL,0,SCON1 Check &FULLSCAN
AEQLC LENFCL,0,FAIL Check length failure
SCON1 POP (YSIZ,YPTR) Restore save descriptors
DECRA YSIZ,1 Decrement possible count
ACOMPC YSIZ,0,,FAIL,INTR13 CHeck for end
ADDLG TXSP,ONECL Increment length of head
BRANCH SCNR2 Continue
*_
UNSC PROC SCNR Backout procedure
MOVD PATBCL,YPTR Reset pattern base
BRANCH SALT3 Join processing
*_
*---------------------------------------------------------------------*
*
* ANY, BREAK, NOTANY, SPAN
*
ANYC PROC , Matching procedure for ANY(S)
SETAC SCL,1 Post entry
ABNS INCRA PATICL,DESCR Increment offset
GETD XPTR,PATBCL,PATICL Get argument
PUSH SCL Save processor switch
ABNS1 VEQLC XPTR,S,,ABNSV E3.5.5
VEQLC XPTR,E,,ABNSE EXPRESSION must be evaluated
VEQLC XPTR,I,,ABNSI E3.5.6
POP SCL E3.5.6
BRANCH SCDTER E3.5.6
*_ E3.5.6
ABNSE RCALL XPTR,EXPVAL,XPTR,(ABNSF,ABNS1) E3.5.5
*_ E3.5.5
ABNSF POP SCL E3.5.5
BRANCH TSALF E3.5.5
*_ E3.5.5
ABNSI RCALL XPTR,GNVARI,XPTR
ABNSV POP SCL Restore procedure switch
AEQLC XPTR,0,,SCNAME E3.5.5
SELBRA SCL,(,BRKV,NNYV,SPNV)
* Select processor
ANYV DEQL XPTR,TBLCS,ANYC2 Was last argument the same?
AEQL TBLFNC,ANYCCL,,ANYC3
* If so, was last procedure for ANY(S)
ANYC2 CLERTB SNABTB,ERROR If not, clear stream table
LOCSP YSP,XPTR
PLUGTB SNABTB,STOP,YSP Plug entries for characters
MOVD TBLCS,XPTR Save argument to check next time
MOVD TBLFNC,ANYCCL Save procedure to check next time
ANYC3 SETSP VSP,XSP Set up working specifier
AEQLC FULLCL,0,ANYC4 Leave length alone in FULLSCAN mode
PUTLG VSP,MAXLEN Else insert maximum length
LCOMP VSP,TXSP,,,TSALT Length failure if too short
CHKVAL MAXLEN,ZEROCL,XSP,,ANYC4,ANYC4 E3.5.7
ADDLG VSP,ONECL E3.5.7
ANYC4 REMSP YSP,VSP,TXSP Get specifier to unscanned portion
STREAM ZSP,YSP,SNABTB,TSALF,TSALT
GETLG XPTR,ZSP Get length accepted
ADDLG TXSP,XPTR Add to length matched
BRANCH SCOK,SCNR Return to success point
*_
BRKC PROC ANYC Matching procedure for BREAK(S)
SETAC SCL,2 Post entry
BRANCH ABNS
*_
BRKV DEQL XPTR,TBLCS,BRKC2 Was last argument the same?
AEQL TBLFNC,BRKCCL,,ANYC3
* Was the last procedure for BREAK
BRKC2 CLERTB SNABTB,CONTIN If not, clear stream table
LOCSP YSP,XPTR
PLUGTB SNABTB,STOPSH,YSP Plug entries for characters
MOVD TBLCS,XPTR Save argument to check next time
MOVD TBLFNC,BRKCCL Save procedure to check next time
BRANCH ANYC3 Proceed
*_
NNYC PROC ANYC Matching procedure for NOTANY(S)
SETAC SCL,3 Post entry
BRANCH ABNS
*_
NNYV DEQL XPTR,TBLCS,NNYC2 Was last argument the same?
AEQL TBLFNC,NNYCCL,,ANYC3
* Was the last procedure for NOTANY?
NNYC2 CLERTB SNABTB,STOP If not, clear stream table
LOCSP YSP,XPTR
PLUGTB SNABTB,ERROR,YSP Plug entries for characters
MOVD TBLCS,XPTR Save argument to check next time
MOVD TBLFNC,NNYCCL Save procedure to check next time
BRANCH ANYC3 Proceed
*_
SPNC PROC ANYC Matching procedure for SPAN(S)
SETAC SCL,4 Post entry
BRANCH ABNS
*_
SPNV DEQL XPTR,TBLCS,SPNC2 Was last argument the same?
AEQL TBLFNC,SPNCCL,,SPNC3
* Was the last procedure for SPAN?
SPNC2 CLERTB SNABTB,STOPSH If not, clear stream table
LOCSP YSP,XPTR
PLUGTB SNABTB,CONTIN,YSP Plug entries for characters
MOVD TBLCS,XPTR Save argument to check next time
MOVD TBLFNC,SPNCCL Save procedure to check next time
SPNC3 LCOMP XSP,TXSP,,TSALT,TSALT
* Length failure if too short
REMSP YSP,XSP,TXSP Get specifier to unscanned portion
STREAM ZSP,YSP,SNABTB,TSALF
LEQLC ZSP,0,,TSALF Failure if length accepted is zero
GETLG XPTR,ZSP Get length of accepted portion
AEQLC FULLCL,0,SPNC5 Skip length check in FULLSCAN mode
CHKVAL MAXLEN,XPTR,TXSP,TSALT
SPNC5 ADDLG TXSP,XPTR Add length accepted
BRANCH SCOK,SCNR
*_
*---------------------------------------------------------------------*
*
* LEN, POS, RPOS, RTAB, TAB
*
LNTH PROC , Matching procedure for LEN(N)
SETAC SCL,1 Note entry
LPRRT INCRA PATICL,DESCR Increment offset
GETD XPTR,PATBCL,PATICL Get argument
PUSH SCL Save entry indicator
*
LPRRT1 VEQLC XPTR,I,,LPRRTI Is it INTEGER?
VEQLC XPTR,E,,LPRRTE Is it EXPRESSION?
VEQLC XPTR,S,,LPRRTV E3.5.6
POP SCL E3.5.6
BRANCH SCDTER E3.5.6
* Is it STRING?
LPRRTE RCALL XPTR,EXPVAL,XPTR,(,LPRRT1) E3.2.1
POP SCL E3.2.1
BRANCH TSALF E3.2.1
*_ E3.2.1
* Evaluate EXPRESSION
LPRRTV LOCSP ZSP,XPTR Get specifier
SPCINT XPTR,ZSP,SCDTER Convert to INTEGER
LPRRTI POP SCL Restore entry indicator
SELBRA SCL,(,POSII,RPSII,RTBI,TBI)
* Select matching procedure
ACOMPC XPTR,0,,,SCLENR Check for negative length
CHKVAL MAXLEN,XPTR,TXSP,TSALT
* Compare with maximum length
ADDLG TXSP,XPTR Add to length matched
BRANCH SCOK,SCNR Return successful match
*_
POSII ACOMPC XPTR,0,,,SCLENR Check for negative position
GETLG NVAL,TXSP Get cursor position
ACOMP XPTR,MAXLEN,TSALT Check desired against maximum
ACOMP XPTR,NVAL,TSALF,TSCOK
* Ceck against cursor position
BRANCH SALT,SCNR
*_
RPSII ACOMPC XPTR,0,,,SCLENR Check for negative position
GETLG NVAL,XSP Get total length
SUBTRT TVAL,NVAL,XPTR Find desired position
GETLG NVAL,TXSP Get cursor position
ACOMP NVAL,TVAL,TSALT,TSCOK,TSALF
* Compare two positions
*_
RTBI ACOMPC XPTR,0,,,SCLENR Check for negative length
GETLG NVAL,XSP Get total length
SUBTRT TVAL,NVAL,XPTR Find desired position
GETLG NVAL,TXSP Get current position
ACOMP NVAL,TVAL,TSALT Compare two positions
AEQLC FULLCL,0,RTBII Check &FULLSCAN
SETAV NVAL,YCL Get residual
SUBTRT NVAL,MAXLEN,NVAL Find maximum allowed position
ACOMP NVAL,TVAL,,,TSALT Compare with desired position
RTBII PUTLG TXSP,TVAL Update length of string matched
BRANCH SCOK,SCNR
*_
TBI ACOMPC XPTR,0,,,SCLENR Check for negative length
GETLG NVAL,TXSP Get cursor position
ACOMP NVAL,XPTR,TSALT Check against desired position
ACOMP XPTR,MAXLEN,TSALT Check for tab beyond end
PUTLG TXSP,XPTR Update length of string matched
BRANCH SCOK,SCNR
*_
POSI PROC LNTH Matching procedure for POS(N)
SETAC SCL,2 Note entry
BRANCH LPRRT Join common processing
*_
RPSI PROC LNTH Matching procedure for RPOS(N)
SETAC SCL,3 Note entry
BRANCH LPRRT Join common processing
*_
RTB PROC LNTH Matching procedure for RTAB(N)
SETAC SCL,4 Note entry
BRANCH LPRRT Join common processing
*_
TB PROC LNTH Matching procedure for TAB(N)
SETAC SCL,5 Note entry
BRANCH LPRRT Join common processing
*_
*---------------------------------------------------------------------*
*
* ARBNO
*
ARBN PROC , Matching for ARBNO(P)
GETLG TMVAL,TXSP Get cursor position
PUSH TMVAL Save cursor position
BRANCH SCOK,SCNR Return matching successfully
*_
ARBF PROC ARBN Backup matching for ARBNO(P)
POP (TMVAL) Restore cursor position
BRANCH ONAR2 Join common processing
*_
EARB PROC ARBN
POP (TMVAL) Restore cursor position
PUTDC PDLPTR,DESCR,TMVAL Insert on history list
GETLG TMVAL,TXSP Get cursor position
PUTDC PDLPTR,2*DESCR,TMVAL
PUTDC PDLPTR,3*DESCR,ZEROCL
BRANCH SCOK,SCNR Return matching successfully
*_
ONAR PROC ARBN
AEQLC FULLCL,0,TSCOK Check &FULLSCAN
MOVD TVAL,ZEROCL
GETAC TVAL,PDLPTR,-2*DESCR
* Get old cursor position
GETLG TMVAL,TXSP Get current cursor position
ACOMP TVAL,TMVAL,TSCOK,,TSCOK
* Compare positions
ONAR1 PUSH TVAL Save cursor position
DECRA PDLPTR,6*DESCR Delete history entries
ONAR2 AEQLC LENFCL,0,TSALT Check length failure
BRANCH SALF,SCNR Return matching failure
*_
ONRF PROC ARBN
MOVD TVAL,ZEROCL
GETAC TVAL,PDLPTR,-2*DESCR
* Get old cursor position
BRANCH ONAR1 Join processing
*_
FARB PROC ,
AEQLC FULLCL,0,,FARB2 Check &FULLSCAN
SETAC NVAL,0 Set residual length to 0
BRANCH FARB3 Join processing
*_
FARB2 AEQLC LENFCL,0,FARB1 Check for length failure
SETAV NVAL,YCL Get residual length
FARB3 GETLG TVAL,TXSP Get cursor position
SUM TVAL,TVAL,NVAL Add them
ACOMP TVAL,MAXLEN,FARB1,FARB1
* Check against maximum
ADDLG TXSP,ONECL Add one for ARB
GETLG TVAL,TXSP Get length matched
PUTAC PDLPTR,2*DESCR,TVAL Insert on history list
BRANCH SCOK,SCNR Return successful match
*_
FARB1 DECRA PDLPTR,3*DESCR Back over history entry
BRANCH SALT,SCNR
*_
*---------------------------------------------------------------------*
*
* @X
*
ATP PROC , Matching procedure for @X
INCRA PATICL,DESCR Increment pattern offset
GETD XPTR,PATBCL,PATICL Get argument
ATP1 VEQLC XPTR,E,,ATPEXN EXPRESSION must be evaluated
GETLG NVAL,TXSP Get length of text matched
SETVC NVAL,I Set INTEGER data type
PUTDC XPTR,DESCR,NVAL Assign as value of variable X
AEQLC OUTSW,0,,ATP2 Check &OUTPUT
LOCAPV ZPTR,OUTATL,XPTR,ATP2
* Look for output association
GETDC ZPTR,ZPTR,DESCR Get output association descriptor
RCALL ,PUTOUT,(ZPTR,NVAL) Perform output
ATP2 AEQLC TRAPCL,0,,TSCOK Check &TRACE
LOCAPT ATPTR,TVALL,XPTR,TSCOK
* Look for trace association
PUSH (PATBCL,PATICL,WPTR,XCL,YCL)
PUSH (MAXLEN,LENFCL,PDLPTR,PDLHED,NAMICL,NHEDCL)
SPUSH (HEADSP,TSP,TXSP,XSP)
MOVD PDLHED,PDLPTR Set new stack heading
MOVD NHEDCL,NAMICL Set new name list heading
RCALL ,TRPHND,ATPTR E3.3.1
* Perform tracing
SPOP (XSP,TXSP,TSP,HEADSP)
POP (NHEDCL,NAMICL,PDLHED,PDLPTR,LENFCL,MAXLEN)
POP (YCL,XCL,WPTR,PATICL,PATBCL)
BRANCH SCOK,SCNR
*_
ATPEXN RCALL XPTR,EXPEVL,XPTR,(TSALF,ATP1,SCNEMO) E3.4.4
*_
*---------------------------------------------------------------------*
*
* BAL
*
BAL PROC , Matching procedure for BAL
BALF1 AEQLC FULLCL,0,,BALF4 Check &FULLSCAN
SETAC NVAL,0 Set length to zero
BRANCH BALF2
*_
BALF4 SETAV NVAL,YCL
BALF2 GETLG TVAL,TXSP Get length of text matched so far
SUM TVAL,TVAL,NVAL Add remainder possible
ACOMP TVAL,MAXLEN,BAL1,BAL1
* Compare to maximum
SUBTRT TVAL,MAXLEN,TVAL Get maximum length for BAL
GETBAL TXSP,TVAL,BAL1 Get balanced string
GETLG TVAL,TXSP Get length matched
PUTAC PDLPTR,2*DESCR,TVAL Insert history entry
BRANCH SCOK,SCNR Successful match
*_
BAL1 DECRA PDLPTR,3*DESCR Back over history entry
ACOMP PDLPTR,PDLHED,TSALF,TSALF,INTR13
*_
BALF PROC BAL Matching procedure for BAL retry
AEQLC FULLCL,0,,BALF3 Check &FULLSCAN
SETAC NVAL,0 If off, set length to zero
BRANCH BALF2 Reenter balanced matching
*_
BALF3 AEQLC LENFCL,0,BAL1,BALF1 If on, test for length failure
*_
*---------------------------------------------------------------------*
*
* Matching for String
*
CHR PROC , Matching character string
INCRA PATICL,DESCR Increment offset
GETD YPTR,PATBCL,PATICL Get argument
CHR1 LOCSP TSP,YPTR Get specifier
CHR2 REMSP VSP,XSP,TXSP Remove part matched
SUBSP VSP,TSP,VSP,TSALT Get part to match
LEXCMP VSP,TSP,TSALF,,TSALF
* Compare strings
GETLG YPTR,TSP Get length
ADDLG TXSP,YPTR Update string matched
BRANCH SCOK,SCNR Return successful match
*_
*---------------------------------------------------------------------*
*
* *X
*
STAR PROC CHR Matching procedure for expressions
INCRA PATICL,DESCR Increment offset
GETD YPTR,PATBCL,PATICL Get argument expression
STAR2 RCALL YPTR,EXPVAL,YPTR,TSALF
* Evaluate argument
VEQLC YPTR,E,,STAR2 Is is EXPRESSION?
SUM XPTR,PATBCL,PATICL Compute pointer to argument
PUTDC XPTR,7*DESCR,YPTR Insert pointer in backup node
VEQLC YPTR,S,,CHR1 Is it STRING?
VEQLC YPTR,P,,STARP Is it PATTERN?
VEQLC YPTR,I,SCDTER Is it INTEGER?
INTSPC TSP,YPTR Get specifier for integer
BRANCH CHR2 Join processing
*_
STARP AEQLC FULLCL,0,,STARP1 Check &FULLSCAN
SETAC NVAL,0 Zero length
BRANCH STARP4 Join processing
*_
STARP1 SETAV NVAL,YCL Get length
STARP4 SUBTRT NVAL,MAXLEN,NVAL Compute residual
ACOMPC NVAL,0,,,TSALT
LVALUE TSIZ,YPTR Check &FULLSCAN
AEQLC FULLCL,0,STARP6
ACOMP TSIZ,NVAL,TSALT Check against length
STARP6 INCRA PDLPTR,3*DESCR Make room for history
ACOMP PDLPTR,PDLEND,INTR31
* Check for overflow
PUTDC PDLPTR,DESCR,SCFLCL Insert failure function
GETLG TMVAL,TXSP Get cursor position
PUTDC PDLPTR,2*DESCR,TMVAL
* Insert on history list
PUTDC PDLPTR,3*DESCR,LENFCL
* Insert length failure
PUSH (MAXLEN,PATBCL,PATICL,XCL,YCL)
* Save scanner state
MOVD MAXLEN,NVAL Set up new maximum
RCALL ,SCIN,,(STARP5,,RTNUL3)
* Call the scanner
STARP2 POP (YCL,XCL,PATICL,PATBCL,MAXLEN)
* Restore scanner state
BRANCH SCOK,SCNR Return matching successfully
*_
STARP5 POP (YCL,XCL,PATICL,PATBCL,MAXLEN)
* Restore scanner state
STARP3 AEQLC LENFCL,0,TSALT Check length failure
BRANCH SALF,SCNR Return matching failure
*_
DSAR PROC CHR Backup matching for expression
INCRA PATICL,DESCR Increment offset
GETD YPTR,PATBCL,PATICL Get argument
VEQLC YPTR,S,,STARP3 Is it STRING?
VEQLC YPTR,P,,DSARP Is it PATTERN?
VEQLC YPTR,I,SCDTER,STARP3
* Is it INTEGER?
*_
DSARP AEQLC FULLCL,0,,DSARP1 Check &FULLSCAN
SETAC NVAL,0 Zero length
BRANCH DSARP2 Join processing
*_
DSARP1 SETAV NVAL,YCL Get length
DSARP2 SUBTRT NVAL,MAXLEN,NVAL Compute residual
PUSH (MAXLEN,PATBCL,PATICL,XCL,YCL)
* Save scanner state
MOVD MAXLEN,NVAL Set up new maximum
RCALL ,UNSC,,(STARP5,STARP2,RTNUL3)
* Call unscanning procedure
*_
*---------------------------------------------------------------------*
*
* FENCE
*
FNCE PROC , Procedure for matching FENCE
INCRA PDLPTR,3*DESCR Create new history entry
ACOMP PDLPTR,PDLEND,INTR31
* Check for overflow
PUTDC PDLPTR,DESCR,FNCFCL Insert FENCE failure function
GETLG TMVAL,TXSP Get length
PUTDC PDLPTR,2*DESCR,TMVAL
* Save length
PUTDC PDLPTR,3*DESCR,LENFCL
* Save length failure switch
SETAC LENFCL,1 Set length failure switch
BRANIC SCOKCL,0 Return matching
*_
*---------------------------------------------------------------------*
*
* X . Y and X $ Y
*
NME PROC , Matching procedure for naming
INCRA PDLPTR,3*DESCR Make room for history entry
ACOMP PDLPTR,PDLEND,INTR31
* Check for end of list
PUTDC PDLPTR,DESCR,FNMECL Insert backup function
GETLG TMVAL,TXSP Get cursor position
PUTDC PDLPTR,2*DESCR,TMVAL
* Put on history list
PUTDC PDLPTR,3*DESCR,LENFCL
* Put length failure indicator
PUSH (TMVAL) Save cursor
SETAC LENFCL,1 Set length failure indicator
BRANCH SCOK,SCNR Return matching successfully
*_
FNME PROC NME Backup procedure for naming
POP (TVAL) Restore cursor
FNME1 AEQLC LENFCL,0,TSALT,TSALF
* Check length failure indicator
*_
ENME PROC NME Naming process for X . Y
INCRA PATICL,DESCR Increment offset
GETD YPTR,PATBCL,PATICL Get argument
POP (NVAL) Restore previous cursor position
SETVA YCL,NVAL Set up length
SETSP TSP,TXSP Copy specifier
PUTLG TSP,NVAL Insert length
REMSP TSP,TXSP,TSP Compute ramainder
SUM TPTR,NBSPTR,NAMICL Compute position on name list
PUTSPC TPTR,DESCR,TSP Insert specifier
PUTDC TPTR,DESCR+SPEC,YPTR
* Insert argument
INCRA NAMICL,DESCR+SPEC Increment list offset
ACOMP NAMICL,NMOVER,INTR13,ENME1
* Check for overflow
ENME2 INCRA PDLPTR,DESCR+SPEC Make room on history list
ACOMP PDLPTR,PDLEND,INTR31
* Check for overflow
PUTDC PDLPTR,DESCR,DNMECL Insert unravelling function
ENME3 GETLG TMVAL,TXSP Get cursor position
MOVV TMVAL,YCL
PUTDC PDLPTR,2*DESCR,TMVAL
* Insert on list
PUTDC PDLPTR,3*DESCR,LENFCL
* Insert length failure
SETAC LENFCL,1 Set length failure
BRANCH SCOK,SCNR Return matching successfully
*_
ENME1 MOVD WCL,NMOVER Save copy of cuurent name list end
INCRA NMOVER,NAMLSZ*SPDR Increment for larger block
RCALL TPTR,BLOCK,NMOVER Allocate larger block
MOVBLK TPTR,NBSPTR,WCL Move in old block
MOVD NBSPTR,TPTR Set up new base pointer
BRANCH ENME2 Rejoin processing
*_
DNME PROC NME Unravelling procedure for naming
DECRA NAMICL,DESCR+SPEC Back off named string
SUM TPTR,NBSPTR,NAMICL Compute current position
DNME1 PROC NME
SETAV VVAL,YCL
PUSH (VVAL) Preserve length
BRANCH FNME1
*_
ENMI PROC NME Matching for X $ Y
INCRA PATICL,DESCR Increment offset
GETD YPTR,PATBCL,PATICL Get argument
POP (NVAL) Restore initial length
SETVA YCL,NVAL Move initial length into value field
SETSP TSP,TXSP Get working specifier
PUTLG TSP,NVAL Insert length
REMSP TSP,TXSP,TSP Get specifier for part matched
GETLG ZCL,TSP Get length of part
ACOMP ZCL,MLENCL,SCLNOR Check &MAXLNGTH
VEQLC YPTR,E,,ENMEXN Is it EXPRESSION?
ENMI5 VEQLC YPTR,K,,ENMIC Check for KEYWORD data type
RCALL VVAL,GENVAR,(TSPPTR)
* Generate variable
ENMI3 PUTDC YPTR,DESCR,VVAL Perform assignment
AEQLC OUTSW,0,,ENMI4 Check &OUTPUT
LOCAPV ZPTR,OUTATL,YPTR,ENMI4
* Look for output association
GETDC ZPTR,ZPTR,DESCR Get association
RCALL ,PUTOUT,(ZPTR,VVAL) Perform output
ENMI4 ACOMPC TRAPCL,0,,ENMI2,ENMI2
* Check &TRACE
LOCAPT ATPTR,TVALL,YPTR,ENMI2
* Look for VALUE trace
PUSH (PATBCL,PATICL,WPTR,XCL,YCL)
* Save relevant descriptors
PUSH (MAXLEN,LENFCL,PDLPTR,PDLHED,NAMICL,NHEDCL)
SPUSH (HEADSP,TSP,TXSP,XSP)
* Save relevant specifiers
MOVD PDLHED,PDLPTR Set up new history list head
MOVD NHEDCL,NAMICL Set up new name list head
RCALL ,TRPHND,ATPTR E3.3.1
* Perform trace
SPOP (XSP,TXSP,TSP,HEADSP)
* Restore specifiers
POP (NHEDCL,NAMICL,PDLHED,PDLPTR,LENFCL,MAXLEN)
* Restore descriptors
POP (YCL,XCL,WPTR,PATICL,PATBCL)
ENMI2 INCRA PDLPTR,3*DESCR Make room on history list
ACOMP PDLPTR,PDLEND,INTR31
* Check for overflow
PUTDC PDLPTR,DESCR,DNMICL Insert unravelling function
BRANCH ENME3 Join common processing
*_
ENMIC SPCINT VVAL,TSP,SCDTER,ENMI3
* Convert STRING to INTEGER
*_
ENMEXN PUSH ZEROCL E3.4.4 & E3.5.8
RCALL YPTR,EXPEVL,YPTR,(TSALF,,SCNEMO) E3.4.4 & E3.5.8
POP ZEROCL E3.4.4 & E3.5.8
BRANCH ENMI5 E3.4.4 & E3.5.8
*_
*---------------------------------------------------------------------*
*
* SUCCEED
*
SUCE PROC , Matching procedure for SUCCEED
SUCE1 INCRA PDLPTR,3*DESCR Make room for history entry
ACOMP PDLPTR,PDLEND,INTR31
* Check for overflow
PUTDC PDLPTR,DESCR,SUCFCL Insert SUCCESS backup function
GETLG TMVAL,TXSP Get length matched
PUTDC PDLPTR,2*DESCR,TMVAL
* Save on history list
PUTDC PDLPTR,3*DESCR,LENFCL
* Save current length failure
SETAC LENFCL,1 Set length failure
BRANIC SCOKCL,0 Return successful match
*_
SUCF PROC SUCE SUCCEED failure
GETDC XCL,PDLPTR,DESCR Get history entries
GETDC YCL,PDLPTR,2*DESCR
BRANCH SUCE1 Go in front door
*_
*---------------------------------------------------------------------*
TITLE 'Defined Functions'
*
* DEFINE(P,E)
*
DEFINE PROC , DEFINE(P,E)
RCALL XPTR,VARVAL,,FAIL Get prototype
PUSH XPTR Save prototype
RCALL YPTR,VARVAL,,FAIL Get entry point
POP XPTR Restore prototype
LOCSP XSP,XPTR Specifier for prototype
STREAM YSP,XSP,VARATB,PROTER,PROTER
* Break out function name
AEQLC STYPE,LPTYP,PROTER Verify open parenthesis
RCALL XPTR,GENVAR,(YSPPTR)
* Get variable for function name
RCALL ZCL,FINDEX,(XPTR) Get function descriptor for function
DEQL YPTR,NULVCL,DEFIN3 Check for omitted entry point
MOVD YPTR,XPTR If omitted use function name
DEFIN3 PUSH YPTR Save entry point
MOVD YCL,ZEROCL Set argument count to 0
PUSH XPTR Save function name
DEFIN4 FSHRTN XSP,1 Remove break character
STREAM YSP,XSP,VARATB,PROTER,PROTER
* Break out argument
SELBRA STYPE,(PROTER,,DEFIN6)
* Check for end
LEQLC YSP,0,,DEFIN4 Check for null argument
RCALL XPTR,GENVAR,(YSPPTR)
* Generate variable for argument
PUSH XPTR Save argument
INCRA YCL,1 Increment argument count
BRANCH DEFIN4 Continue
*_
DEFIN6 LEQLC YSP,0,,DEFIN9
INCRA YCL,1 Increment argument count
RCALL XPTR,GENVAR,(YSPPTR)
* Generate variable for argument
PUSH XPTR Save argument
DEFIN9 SETVA DEFCL,YCL
DEFIN8 FSHRTN XSP,1
STREAM YSP,XSP,VARATB,PROTER,DEF10
* Break out local arguments
AEQLC STYPE,CMATYP,PROTER Verify comma
LEQLC YSP,0,,DEFIN8 Check for null argument
RCALL XPTR,GENVAR,(YSPPTR)
* Generate variable
PUSH XPTR Save local argument
INCRA YCL,1 Increment total count
BRANCH DEFIN8 Continue
*_
DEF10 LEQLC YSP,0,,DEF11 Check for null argument
RCALL XPTR,GENVAR,YSPPTR Generate variable
PUSH XPTR Save argument
INCRA YCL,1 Increment total count
DEF11 INCRA YCL,2 Increment for name and label
MULTC XCL,YCL,DESCR Convert to address units
SETVC XCL,B Insert block data type
RCALL XPTR,BLOCK,XCL Allocate block for definition
PUTDC ZCL,0,DEFCL Point to procedure descriptor
PUTDC ZCL,DESCR,XPTR Insert definition block
SUM XPTR,XPTR,XCL Compute end of block
DEF12 DECRA XPTR,DESCR Decrement pointer
POP YPTR Restore argument
PUTDC XPTR,DESCR,YPTR Insert in definition block
DECRA YCL,1 Decrement total count
AEQLC YCL,0,DEF12,RETNUL Check for end
*_
*---------------------------------------------------------------------*
*
* Invocation of Defined Function
*
DEFFNC PROC , Procedure to invoke defined function
SETAV XCL,INCL Get number of arguments in call
MOVD WCL,XCL Save copy
MOVD YCL,INCL Save function descriptor
PSTACK YPTR Post stack position
PUSH NULVCL Save null value for function name
DEFF1 INCRA OCICL,DESCR Increment offset
GETD XPTR,OCBSCL,OCICL Get object code descriptor
TESTF XPTR,FNC,,DEFFC Check for function descriptor
DEFF2 AEQLC INSW,0,,DEFF14 Check &INPUT
LOCAPV ZPTR,INATL,XPTR,DEFF14
* Look for input association
GETDC ZPTR,ZPTR,DESCR Get association
PUSH (XCL,WCL,YCL,YPTR) Save relevant descriptors
RCALL XPTR,PUTIN,(ZPTR,XPTR),FAIL
* Perform input
POP (YPTR,YCL,WCL,XCL) Restore descriptors
BRANCH DEFF3 Join processing
*_
DEFF14 GETDC XPTR,XPTR,DESCR Get value
DEFF3 PUSH XPTR Save value
DECRA XCL,1 Decrement argument count
ACOMPC XCL,0,DEFF1,,INTR10 Check for end
GETDC XCL,YCL,0 Get expected number of arguments
SETAV XCL,XCL Insert in A-field
DEFF4 ACOMP WCL,XCL,DEFF9,DEFF5 Compare given and expected
PUSH NULVCL Not enough, save null string
INCRA WCL,1 Increment count
BRANCH DEFF4 Continue
*_
DEFF9 POP ZCL Throw away extra argument
DECRA WCL,1 Decrement count
BRANCH DEFF4 Continue
*_
DEFF5 GETDC ZCL,YCL,DESCR Get definition block
MOVD XPTR,ZCL Save copy
GETSIZ WCL,ZCL Get size of block
SUM WPTR,ZCL,WCL Compute pointer to end
INCRA XCL,1 Increment for function name
DEFF8 INCRA XPTR,DESCR Increment pointer to block
INCRA YPTR,DESCR Adjust stack pointer
GETDC ZPTR,XPTR,DESCR Get argument name
GETDC TPTR,ZPTR,DESCR Get current argument value
GETDC ATPTR,YPTR,DESCR Get value from stack
PUTDC ZPTR,DESCR,ATPTR Assign to argument name
PUTDC YPTR,DESCR,TPTR Put current argument on stack
DECRA XCL,1 Decrement count
ACOMPC XCL,0,DEFF8,,INTR10 Check for end
DEFF10 INCRA XPTR,DESCR Increment pointer to block
AEQL XPTR,WPTR,,DEFFGO
GETDC ZPTR,XPTR,DESCR Get argument name from block
GETDC TPTR,ZPTR,DESCR Get current value of argument
PUSH TPTR Save current value
PUTDC ZPTR,DESCR,NULVCL Assign null value to local
BRANCH DEFF10 Continue
*_
DEFFGO PUSH (FRTNCL,STNOCL,OCICL,OCBSCL,ZCL,ZCL)
* Save system state
GETDC XCL,ZCL,DESCR Get entry label
AEQLIC XCL,ATTRIB,0,,UNDFFE E3.0.2
GETDC OCBSCL,XCL,ATTRIB E3.0.2
ACOMPC TRACL,0,,DEFF18,DEFF18
* Check &FTRACE
DECRA TRACL,1 Decrement &FTRACE
GETDC ATPTR,ZCL,2*DESCR Get function name
PUSH ZCL Save definition block
RCALL ,FENTR2,(ATPTR),(INTR10,INTR10)
* Perform function trace
POP ZCL Restore definition block
DEFF18 ACOMPC TRAPCL,0,,DEFF19,DEFF19
* Check &TRACE
GETDC ATPTR,ZCL,2*DESCR Get function name
LOCAPT ATPTR,TFENTL,ATPTR,DEFF19
* Check for CALL trace
PUSH (OCBSCL,ZCL) Save object code base and block
RCALL ,TRPHND,ATPTR E3.3.1
* Perform trace
POP (ZCL,OCBSCL) Restore base and block
DEFF19 INCRA LVLCL,1 Increment &FNCLEVEL
ACOMPC TRAPCL,0,,DEFF15,DEFF15
* Check &TRACE
LOCAPT ATPTR,TKEYL,FNCLKY,DEFF15
* Look for KEYWORD trace
RCALL ,TRPHND,ATPTR E3.3.1
* Perform trace
DEFF15 SETAC OCICL,0 Zero offset
RCALL ,INTERP,,(DEFFF,DEFFNR)
* Call interpreter
MOVD RETPCL,RETCL Set &RTNTYPE to RETURN
DEFFS1 POP ZCL Restore definition block
ACOMPC TRACL,0,,DEFF20,DEFF20
* Check &FTRACE
DECRA TRACL,1 Decrement &FTRACE
GETDC ATPTR,ZCL,2*DESCR Get function name
PUSH ZCL Save definition block
RCALL ,FNEXT2,(ATPTR),(INTR10,INTR10)
* Perform function trace
POP ZCL Restore definition block
DEFF20 ACOMPC TRAPCL,0,,DEFFS2,DEFFS2
* Check &TRACE
GETDC ATPTR,ZCL,2*DESCR Get function name
LOCAPT ATPTR,TFEXTL,ATPTR,DEFFS2
* Check for RETURN trace
PUSH (RETPCL,ZCL) Save return and block
RCALL ,TRPHND,ATPTR E3.3.1
* Perform trace
POP (ZCL,RETPCL) Restore block and return
DEFFS2 DECRA LVLCL,1 Decrement &FNCLEVEL
ACOMPC TRAPCL,0,,DEFF17,DEFF17
* Check &TRACE
LOCAPT ATPTR,TKEYL,FNCLKY,DEFF17
* Check for KEYWORD trace
PUSH (RETPCL,ZCL) Save return and block
RCALL ,TRPHND,ATPTR E3.3.1
* Perform trace
POP (ZCL,RETPCL) Restore block and return
DEFF17 POP (ZCL,OCBSCL,OCICL,STNOCL,FRTNCL)
* Restore system state
GETSIZ WCL,ZCL Get size of definition block
DECRA WCL,DESCR Decrement pointer
ACOMPC WCL,0,,INTR10,INTR10
* Check for end
SUM WPTR,ZCL,WCL Compute pointer to last descriptor
MOVD YPTR,ZCL Save pointer to block
INCRA YPTR,DESCR Increment pointer
GETDC ZPTR,YPTR,DESCR Get function name
GETDC ZPTR,ZPTR,DESCR Get value to be returned
DEFF6 POP XPTR Get old value
GETDC YPTR,WPTR,DESCR Get argument name
PUTDC YPTR,DESCR,XPTR Restore old value
DECRA WPTR,DESCR Decrement pointer
AEQL WPTR,ZCL,DEFF6 Check for end
DEQL RETPCL,FRETCL,,FAIL Check for FRETURN
DEQL RETPCL,NRETCL,RTZPTR
* Check for NRETURN
MOVD XPTR,ZPTR Move name to correct descriptor
VEQLC XPTR,S,,DEFFVX Check for natural variable
VEQLC XPTR,I,,GENVIX Convert integer
VEQLC XPTR,N,,RTXNAM Check for created variable
VEQLC XPTR,K,NONAME,RTXNAM
* Check for keyword variable
DEFFVX AEQLC XPTR,0,RTXNAM,NONAME
* Check for null string
*_
DEFFF MOVD RETPCL,FRETCL Set up FRETURN
BRANCH DEFFS1 Join processing
*_
DEFFC PUSH (XCL,WCL,YCL,YPTR) Save relevant descriptors
RCALL XPTR,INVOKE,(XPTR),(FAIL,DEFFN)
* Evaluate argument
POP (YPTR,YCL,WCL,XCL) Restore relevant variables
BRANCH DEFF3 Join processing
*_
DEFFN POP (YPTR,YCL,WCL,XCL) Restore relevant variables
BRANCH DEFF2 Join processing
*_
DEFFNR MOVD RETPCL,NRETCL Set up NRETURN
BRANCH DEFFS1 Join processing
*_
*---------------------------------------------------------------------*
TITLE 'External Functions'
*
* LOAD(P)
*
LOAD PROC , LOAD(P)
RCALL XPTR,VARVAL,,FAIL Get prototype
PUSH XPTR Save prototype
RCALL WPTR,VARVAL,,FAIL Get library name
LOCSP VSP,WPTR Get specifier for library
POP XPTR Restore prototypr
LOCSP XSP,XPTR Get specifier for prototype
STREAM YSP,XSP,VARATB,PROTER,PROTER
* Get function name from prototype
AEQLC STYPE,LPTYP,PROTER Verify left parenthesis
RCALL XPTR,GENVAR,YSPPTR Generate variable for function
RCALL ZCL,FINDEX,XPTR Find function
MOVD YCL,ZEROCL Set argument count to zero
LOAD4 FSHRTN XSP,1 Remove break character
STREAM ZSP,XSP,VARATB,LOAD1,PROTER
* Break out argument
SELBRA STYPE,(PROTER,,LOAD6)
* Branch on break type
RCALL XPTR,GENVAR,ZSPPTR Generate variable for data type
LOCAPV XPTR,DTATL,XPTR,LOAD9
* Look up data type
GETDC XPTR,XPTR,DESCR Extract data type code
PUSH XPTR Save data type code
LOAD10 INCRA YCL,1 Increment count of arguments
BRANCH LOAD4 Continue
*_
LOAD6 INCRA YCL,1 Count last argument
RCALL XPTR,GENVAR,ZSPPTR Generate variable for data type
LOCAPV XPTR,DTATL,XPTR,LOAD11
* Look up data type
GETDC XPTR,XPTR,DESCR Get data type code
PUSH XPTR Save data type code
LOAD13 FSHRTN XSP,1 Delete right parenthesis
RCALL XPTR,GENVAR,XSPPTR Generate variable for target
LOCAPV XPTR,DTATL,XPTR,LOAD7
* Look up data type
GETDC XPTR,XPTR,DESCR Get data type code
PUSH XPTR Save data type code
LOAD8 SETVA LODCL,YCL Insert number of arguments
INCRA YCL,1 Increment count
MULTC XCL,YCL,DESCR Convert to address units
INCRA XCL,DESCR Add space for entry point
SETVC XCL,B Insert BLOCK data type
RCALL XPTR,BLOCK,XCL Allocate block for definition
PUTDC ZCL,0,LODCL Insert procedure descriptor
PUTDC ZCL,DESCR,XPTR Insert definition block
SUM XPTR,XPTR,XCL Compute pointer to end of block
LOAD12 DECRA XPTR,DESCR Decrement pointer
POP YPTR Restore data type
PUTDC XPTR,DESCR,YPTR Insert in block
DECRA YCL,1 Decrement count
ACOMPC YCL,0,LOAD12 Check for end
LOAD YPTR,YSP,VSP,FAIL Load external function
PUTDC XPTR,0,YPTR Insert entry point
BRANCH RETNUL Return null string as value
*_
LOAD7 PUSH ZEROCL Save 0 for unspecified type
BRANCH LOAD8 Continue
*_
LOAD9 PUSH ZEROCL Save 0 for unspecified type
BRANCH LOAD10 Continue
*_
LOAD1 PUSH ZEROCL Save 0 for unspecified type
SETSP TSP,XSP Set up break check
SETLC TSP,1 Set length to 1
INCRA YCL,1
LEXCMP TSP,RPRNSP,LOAD4,LOAD13,LOAD4
*_
LOAD11 PUSH ZEROCL Save 0 for unspecified type
BRANCH LOAD13 Continue
*_
*---------------------------------------------------------------------*
*
* UNLOAD(F)
*
UNLOAD PROC , UNLOAD(F)
RCALL XPTR,VARVAL,,FAIL Get function name
RCALL ZCL,FINDEX,XPTR Locate function descriptor
PUTDC ZCL,0,UNDFCL Undefine function
LOCSP XSP,XPTR Get specifier
UNLOAD XSP Unload external definition
BRANCH RETNUL Return
*_
*---------------------------------------------------------------------*
*
* Linkage to External Functions
*
LNKFNC PROC , Procedure to link to externals
SETAV XCL,INCL Get actual number of arguments
MOVD YCL,INCL Save function descriptor
SETAV WCL,YCL E3.9.1
GETDC ZCL,YCL,DESCR Get definition block
PSTACK YPTR Post stack position
SETAC TCL,2*DESCR Set offset for first argument
LNKF1 PUSH (XCL,ZCL,TCL,YPTR,WCL,YCL)
* Save working descriptors
RCALL XPTR,ARGVAL,,FAIL Evaluate argument
POP (YCL,WCL,YPTR,TCL,ZCL,XCL)
* Restore working descriptors
DECRA WCL,1 E3.9.1
ACOMPC WCL,0,,,LNKF8 E3.9.1
LNKF7 GETD ZPTR,ZCL,TCL Get data type required
VEQLC ZPTR,0,,LNKF6 Check for possible conversion
VEQL ZPTR,XPTR,,LNKF6 Skip if data types the same
SETAV DTCL,XPTR Data type of argument
MOVV DTCL,ZPTR Data type required
DEQL DTCL,VIDTP,,LNKVI STRING-INTEGER
DEQL DTCL,IVDTP,,LNKIV INTEGER-STRING
DEQL DTCL,RIDTP,,LNKRI REAL-INTEGER
DEQL DTCL,IRDTP,,LNKIR INTEGER-REAL
DEQL DTCL,RVDTP,,LNKRV REAL-STRING
DEQL DTCL,VRDTP,INTR1,LNKVR
* STRING-REAL
LNKIV RCALL XPTR,GNVARI,XPTR,LNKF6
* Convert INTEGER to STRING
*_
LNKRI RLINT XPTR,XPTR,INTR1,LNKF6
* Convert REAL to INTEGER
*_
LNKIR INTRL XPTR,XPTR Convert INTEGER to REAL
BRANCH LNKF6
*_
LNKVR LOCSP XSP,XPTR Get specifier
SPCINT XPTR,XSP,,LNKIR Convert STRING to INTEGER
SPREAL XPTR,XSP,INTR1,LNKF6
* Convert STRING to REAL
*_
LNKRV REALST XSP,XPTR
RCALL XPTR,GENVAR,XSPPTR,LNKF6
*_
LNKVI LOCSP XSP,XPTR Get specifier
SPCINT XPTR,XSP,,LNKF6 Convert to INTEGER
SPREAL XPTR,XSP,INTR1,LNKRI
* Convert STRING to REAL
LNKF6 INCRA TCL,DESCR Increment offset
PUSH XPTR Save argument
LNKF8 DECRA XCL,1 E3.9.1
ACOMPC XCL,0,LNKF1 E3.9.1
GETDC WPTR,YCL,0 Get procedure descriptor
SETAV WPTR,WPTR Get argument count required
LNKF4 ACOMPC WCL,0,,LNKF5,LNKF5 E3.9.1
PUSH NULVCL E3.9.1
DECRA WCL,1 Decrement argument count
BRANCH LNKF4 Continue
*_
LNKF5 GETSIZ WCL,ZCL Get size of definition block
SUM XPTR,ZCL,WCL Compute pointer to end
GETDC ZPTR,XPTR,0 Get data target descriptor
GETDC ZCL,ZCL,DESCR Get function address
INCRA YPTR,2*DESCR Get pointer to argument list
LINK ZPTR,YPTR,WPTR,ZCL,FAIL
* Link to external function
VEQLC ZPTR,L,RTZPTR Check for linked string
GETSPC ZSP,ZPTR,0 Get specifier
BRANCH GENVRZ Go generate variable
*_
*---------------------------------------------------------------------*
TITLE 'Arrays, Tables, and Defined Data Objects'
*
* ARRAY(P,V)
*
ARRAY PROC , ARRAY(P,V)
RCALL XPTR,VARVAL,,FAIL Get prototype
PUSH XPTR Save prototype
RCALL TPTR,ARGVAL,,FAIL Get initial value for array elements
POP XPTR Restore prototype
SETAC ARRMRK,0 Clear prototype analysis switch
MOVD WCL,ZEROCL Initialize dimensionality to zero
MOVD XCL,ONECL Initialize size to one
LOCSP XSP,XPTR Get specifier to prototype
PUSH XPTR Save prototype for later insertion
ARRAY1 STREAM YSP,XSP,NUMBTB,PROTER,ARROT1 E3.5.1
SPCINT YCL,YSP,PROTER Convert string to integer
SELBRA STYPE,(,ARRAY3) Branch on colon or comma
FSHRTN XSP,1 Delete colon
STREAM ZSP,XSP,NUMBTB,PROTER,ARROT2
SPCINT ZCL,ZSP,PROTER Convert upper bound to integer
SELBRA STYPE,(PROTER,ARRAY5)
* Verify break character
*_
ARRAY3 ACOMPC YCL,0,,PROTER,PROTER
* Single number must be positive
MOVD ZCL,YCL Move to copy
SETAC YCL,1 Set lower bound to default of one
BRANCH ARRAY6
*_
ARRAY5 SUBTRT ZCL,ZCL,YCL Compute difference
SUM ZCL,ZCL,ONECL Add one
ACOMPC ZCL,0,,,PROTER
ARRAY6 SETVA YCL,ZCL Insert width of dimension
PUSH YCL Save dimension information
MULT XCL,XCL,ZCL,PROTER Compute size of array to this point
INCRA WCL,1 Increase count of dimensions
AEQLC ARRMRK,0,ARRAY7 E3.5.1
FSHRTN XSP,1 Remove break character
BRANCH ARRAY1
*_
ARROT1 SETAC ARRMRK,1 On run out, mark end of prototype
SPCINT YCL,YSP,PROTER,ARRAY3
* Convert string to integer
*_
ARROT2 SETAC ARRMRK,1 On run out, mark end of prototype
SPCINT ZCL,ZSP,PROTER,ARRAY5
* Convert string to integer
*_
ARRAY7 SUM ZCL,XCL,WCL Add dimensionality to array size
INCRA ZCL,2 Add two for heading information
MULTC ZCL,ZCL,DESCR Convert to address units
SETVC ZCL,A Insert ARRAY data type
RCALL ZPTR,BLOCK,ZCL Allocate block for array structure
MOVD XPTR,ZPTR Save copy
SUM WPTR,XPTR,ZCL Get pointer to last descriptor
PUTDC ZPTR,2*DESCR,WCL Insert dimensionality
INCRA XPTR,DESCR Update working pointer
ARRAY8 INCRA XPTR,DESCR Update working pointer for another
POP YPTR Restore index pair
PUTDC XPTR,DESCR,YPTR Insert in structure
DECRA WCL,1 Decrement dimensionality
ACOMPC WCL,0,ARRAY8,ARRFIL Check for last one
ARRAY9 PUTDC XPTR,DESCR,TPTR Insert initial value
ARRFIL INCRA XPTR,DESCR Update working pointer
ACOMP XPTR,WPTR,INTR10,,ARRAY9
* Check for end
POP WPTR RESTORE PROTOTYPE E3.10.1
PUTDC ZPTR,DESCR,WPTR RETURN POINTER TO ARRAY E3.10.1
BRANCH RTZPTR Return pointer to array structure
*_
*---------------------------------------------------------------------*
*
* TABLE(N,M)
*
ASSOC PROC , TABLE(N,M)
RCALL XPTR,INTVAL,,FAIL Get table size
PUSH XPTR Save size
RCALL WPTR,INTVAL,,FAIL Get secondary allocation
MULT ZPTR,WPTR,DSCRTW,SIZERR E3.10.4
INCRA ZPTR,2*DESCR E3.10.4
ACOMP ZPTR,SIZLMT,SIZERR,SIZERR E3.10.4
POP XPTR Restore size
ACOMPC XPTR,0,ASSOC1,,LENERR
SETAC XPTR,EXTSIZ
ASSOC1 INCRA XPTR,1 E3.2.3
MULTC XPTR,XPTR,2*DESCR E3.2.3
ACOMPC WPTR,0,ASSOC4,,LENERR
SETAC WPTR,EXTSIZ
ASSOC4 INCRA WPTR,1 E3.2.3
MULTC WPTR,WPTR,2*DESCR E3.2.3
SETVC XPTR,T E3.2.3
ASSOCE PROC ASSOC E3.2.3
RCALL ZPTR,BLOCK,XPTR E3.2.3
PUTD ZPTR,XPTR,ONECL E3.2.3
DECRA XPTR,DESCR E3.2.3
PUTD ZPTR,XPTR,WPTR E3.2.3
ASSOC2 DECRA XPTR,2*DESCR E3.2.3
PUTD ZPTR,XPTR,NULVCL E3.2.3
AEQLC XPTR,DESCR,ASSOC2,RTZPTR E3.2.3
*_
*---------------------------------------------------------------------*
*
* DATA(P)
*
DATDEF PROC , DATA(P)
RCALL XPTR,VARVAL,,FAIL Get prototype
SETAC DATACL,0 Initialize prototype switch
LOCSP XSP,XPTR Get specifier
STREAM YSP,XSP,VARATB,PROTER,PROTER
* Break out data type name
AEQLC STYPE,LPTYP,PROTER Verify left parenthesis
RCALL XPTR,GENVAR,(YSPPTR)
* Generate variable for name
RCALL ZCL,FINDEX,(XPTR) Find function descriptor
INCRV DATSEG,1 Increment data type code
VEQLC DATSEG,DATSIZ,,INTR27
* Check against limit
MOVD YCL,ZEROCL Initialize count of fields
RCALL DTATL,AUGATL,(DTATL,DATSEG,XPTR)
* Augment data type pair list
PSTACK WPTR Post stack position
PUSH (DATSEG,XPTR) Save code and name
DATA3 FSHRTN XSP,1 Delete break character
AEQLC DATACL,0,DAT5 Check for prototype end
STREAM YSP,XSP,VARATB,PROTER,PROTER
* Break out field
SELBRA STYPE,(PROTER,,DATA6)
DATA4 LEQLC YSP,0,,DATA3 Check for zero length
RCALL XPTR,GENVAR,YSPPTR Generate variable
PUSH XPTR Save field name
RCALL XCL,FINDEX,(XPTR) Find function descriptor for field
GETDC WCL,XCL,0 Get procedure descriptor
DEQL WCL,FLDCL,DAT6 Check for FIELD procedure
GETDC ZPTR,XCL,DESCR Get field definition block
MULTC TCL,YCL,DESCR
RCALL ZPTR,AUGATL,(ZPTR,DATSEG,TCL)
DAT7 PUTDC XCL,DESCR,ZPTR Insert new definition block
INCRA YCL,1
BRANCH DATA3 Continue
*_
DATA6 SETAC DATACL,1 Note end of prototype analysis
BRANCH DATA4 Join field processing
*_
DAT5 LEQLC XSP,0,PROTER Verify prototype consumption
AEQLC YCL,0,,PROTER E3.1.2
SETVA DATCL,YCL Insert field count for data function
PUTDC ZCL,0,DATCL Insert new procedure descriptor
MULTC YCL,YCL,DESCR
INCRA YCL,2*DESCR Add two for the number and name
MOVV YCL,DATSEG Insert defined data code
RCALL ZPTR,BLOCK,YCL Allocate definition block
INCRA WPTR,DESCR E3.0.3
MOVBLK ZPTR,WPTR,YCL Copy from stack into block
PUTDC ZCL,DESCR,ZPTR Insert definition block
BRANCH RETNUL Return null value
*_
DAT6 PUTDC XCL,0,FLDCL Insert FIELD procedure descriptor
RCALL ZPTR,BLOCK,TWOCL Allocate definition block
PUTDC ZPTR,DESCR,DATSEG Insert data type code
MULTC TCL,YCL,DESCR
PUTDC ZPTR,2*DESCR,TCL
BRANCH DAT7 Join processing
*_
*---------------------------------------------------------------------*
*
* PROTOTYPE(A)
*
PROTO PROC , PROTOTYPE(A)
RCALL XPTR,ARGVAL,,FAIL Get argument
VEQLC XPTR,A,NONARY Verify ARRAY
GETDC ZPTR,XPTR,DESCR Get prototype
BRANCH RTZPTR Return
*_
*---------------------------------------------------------------------*
*
* Array and Table References
*
ITEM PROC , Array or table reference
SETAV XCL,INCL Get argument count
DECRA XCL,1 Skip referenced object
PUSH XCL Save count
RCALL YCL,ARGVAL,,FAIL Get referenced object
POP XCL Restore count
VEQLC YCL,A,,ARYAD3 ARRAY is acceptable
VEQLC YCL,T,NONARY,ASSCR TABLE is acceptable
ARYAD3 MOVD WCL,XCL Save copy of argument count
ARYAD1 ACOMPC XCL,0,,ARYAD2,ARYAD2
* Count down on arguments
PUSH (XCL,WCL,YCL) Save
RCALL XPTR,INTVAL,,FAIL Get index
POP (YCL,WCL,XCL) Restore saved descriptors
PUSH XPTR Save index
DECRA XCL,1 Decrement argument count
BRANCH ARYAD1
*_
ARYAD2 MOVD ZPTR,ZEROCL Initialize offset to zero
GETDC ZCL,YCL,2*DESCR Get number of dimensions
MULTC YPTR,ZCL,DESCR Convert to addressing units
SUM YPTR,YCL,YPTR Add base and offset
INCRA YPTR,2*DESCR Add two for heading
ARYAD7 ACOMP WCL,ZCL,ARGNER,ARYAD9
* Compare given and required number
PUSH ZEROCL If too few, supply a zero
INCRA WCL,1 Increment and loop
BRANCH ARYAD7
*_
ARYAD9 INCRA YCL,2*DESCR
GETDC WPTR,YCL,DESCR Get index pair
SETAV TPTR,WPTR Get extent of dimension
ARYA11 POP XPTR Get index value
SUBTRT XPTR,XPTR,WPTR Compute differnece from lower bound
ACOMPC XPTR,0,,,FAIL If less than zero, out of bounds
ACOMP XPTR,TPTR,FAIL,FAIL If greater than extent, out of bound
SUM XPTR,ZPTR,XPTR Else add to evolving sum
DECRA ZCL,1 Decrement dimension count
ACOMPC ZCL,0,,ARYA12 Get out if done
INCRA YCL,DESCR Adjust bas pointer
GETDC WPTR,YCL,DESCR Get index pair
SETAV TPTR,WPTR Get extent of dimension
MULT ZPTR,XPTR,TPTR Multiply for next dimension
BRANCH ARYA11 Continue with next dimension
*_
ARYA12 MULTC XPTR,XPTR,DESCR Expand offset into addressing units
SUM XPTR,YPTR,XPTR Add to adjusted base
ARYA10 SETVC XPTR,N Insert NAME data type
BRANCH RTXNAM Return interior pointer
*_
ASSCR AEQLC XCL,1,ARGNER Only one argument for tables
PUSH YCL Save pointer to object
RCALL YPTR,ARGVAL,,FAIL Evaluate argument
POP XPTR E3.2.3
ASSCR5 LOCAPV WPTR,XPTR,YPTR,,ASSCR4 E3.2.3
LOCAPV WPTR,XPTR,ZEROCL,ASSCR2
* Look for item with null value
ASSCR4 MOVA XPTR,WPTR
PUTDC XPTR,2*DESCR,YPTR E3.2.3
BRANCH ARYA10 Join array reference exit
*_
ASSCR2 GETSIZ TCL,XPTR E3.2.3
GETD ZPTR,XPTR,TCL E3.2.3
AEQLC ZPTR,1,,ASSCR3 E3.2.3
MOVD XPTR,ZPTR E3.2.3
BRANCH ASSCR5 E3.2.3
*_ E3.2.3
ASSCR3 DECRA TCL,DESCR E3.2.3
GETD WPTR,XPTR,TCL E3.2.3
PUSH (XPTR,TCL,YPTR) E3.2.3
MOVD XPTR,WPTR E3.2.3
RCALL ZPTR,ASSOCE,,(INTR10,INTR10) E3.2.3
POP (YPTR,TCL,XPTR) E3.2.3
SETVC ZPTR,B E3.2.3
INCRA TCL,DESCR E3.2.3
PUTD XPTR,TCL,ZPTR E3.2.3
PUTDC ZPTR,2*DESCR,YPTR E3.2.3
MOVD XPTR,ZPTR E3.2.3
BRANCH ARYA10 E3.2.3
*_
*---------------------------------------------------------------------*
* Defined Object Creation
*
DEFDAT PROC , Procedure to create defined objects
SETAV XCL,INCL Get given number of arguments
MOVD WCL,XCL Save a copy
MOVD YCL,INCL Save function descriptor
PSTACK YPTR Post stack position
DEFD1 INCRA OCICL,DESCR Increment offset
GETD XPTR,OCBSCL,OCICL Get object code descriptor
TESTF XPTR,FNC,,DEFDC Check for function
DEFD2 AEQLC INSW,0,,DEFD8 Check &INPUT
LOCAPV ZPTR,INATL,XPTR,DEFD8
* Look for input association
GETDC ZPTR,ZPTR,DESCR Get association
PUSH (XCL,WCL,YCL,YPTR) Save relevant descriptors
RCALL XPTR,PUTIN,(ZPTR,XPTR),FAIL
POP (YPTR,YCL,WCL,XCL) Restore relevant descriptors
BRANCH DEFD3 Join main processing
*_
DEFD8 GETDC XPTR,XPTR,DESCR Get value
DEFD3 PUSH XPTR Save value
DECRA XCL,1 Decrement argument count
ACOMPC XCL,0,DEFD1,,INTR10 Check for end
GETDC XCL,YCL,0 Get procedure descriptor
SETAV XCL,XCL Get number of arguments expected
DEFD4 ACOMP WCL,XCL,DEFD5,DEFD5 Compare given with expected
PUSH NULVCL Save null for omitted argument
INCRA WCL,1 Increment count
BRANCH DEFD4 Continue
*_
DEFD5 GETDC WCL,YCL,DESCR Get definition block
MULTC XCL,XCL,DESCR
MOVV XCL,WCL Insert data type code
RCALL ZPTR,BLOCK,XCL Allocate block for data object
INCRA YPTR,DESCR Adjust stack position
MOVBLK ZPTR,YPTR,XCL Move values into block
BRANCH RTZPTR Return new object
*_
DEFDC PUSH (XCL,WCL,YCL,YPTR) Save relevant descriptors
RCALL XPTR,INVOKE,(XPTR),(FAIL,DEFDN)
POP (YPTR,YCL,WCL,XCL) Restore relevant descriptors
BRANCH DEFD3 Join main processing
*_
DEFDN POP (YPTR,YCL,WCL,XCL) Restore relevant descriptors
BRANCH DEFD2 Join main processing
*_
*---------------------------------------------------------------------*
*
* Fields of Defined Data Objects
*
FIELD PROC , Field function procedure
PUSH INCL Save function descriptor
RCALL XPTR,ARGVAL,,FAIL Get value
DEQL XPTR,NULVCL,,NONAME Check for null value
POP YCL Restore function descriptor
VEQLC XPTR,I,FIELD1 Check for INTEGER
RCALL XPTR,GNVARI,XPTR Convert INTEGER to STRING
FIELD1 MOVV DT1CL,XPTR Set up data type
GETDC YPTR,YCL,DESCR Get definition block
LOCAPT ZCL,YPTR,DT1CL,INTR1
* Look for data type offset
GETDC ZCL,ZCL,2*DESCR Get offset
SUM XPTR,XPTR,ZCL Compute field position
SETVC XPTR,N Insert NAME data type
BRANCH RTXNAM Return name
*_
*---------------------------------------------------------------------*
TITLE 'Input and Output'
*
* INPUT(V,U,L)
*
READ PROC , INPUT(V,U,L)
RCALL XPTR,IND,,FAIL Get variable
PUSH XPTR Save variable
RCALL YPTR,INTVAL,,FAIL Get unit
PUSH YPTR Save unit
RCALL ZPTR,INTVAL,,FAIL Get length
POP (YPTR,XPTR) Restore unit and variable
ACOMPC YPTR,0,,READ5,UNTERR
* Check for defaulted unit
READ6 ACOMPC ZPTR,0,READ2,,LENERR
* Check for defaulted length
LOCAPT TPTR,INSATL,YPTR,READ4
* Look for default length
READ3 LOCAPV ZPTR,INATL,XPTR,READ1
* Look for existing association
PUTDC ZPTR,DESCR,TPTR Inset input block
BRANCH RETNUL Return
*_ Add new association pair
READ1 RCALL INATL,AUGATL,(INATL,TPTR,XPTR),RETNUL
*_
READ4 MOVD ZPTR,DFLSIZ Set standard default
READ2 RCALL TPTR,BLOCK,IOBLSZ Allocate block
PUTDC TPTR,DESCR,YPTR Insert unit
PUTDC TPTR,2*DESCR,ZPTR Insert format
BRANCH READ3 Rejoin processing
*_
READ5 SETAC YPTR,UNITI Set up default unit
BRANCH READ6 Join processing
*_
*---------------------------------------------------------------------*
*
* OUTPUT(V,U,F)
*
PRINT PROC , OUTPUT(V,U,F)
RCALL XPTR,IND,,FAIL Get variable
PUSH XPTR Save variable
RCALL YPTR,INTVAL,,FAIL Get unit
PUSH YPTR Save unit
RCALL ZPTR,VARVAL,,FAIL Get format
POP (YPTR,XPTR) Restore unit and variable
ACOMPC YPTR,0,,PRINT5,UNTERR
PRINT6 AEQLC ZPTR,0,PRINT2 Check for defaulted format
LOCAPT TPTR,OTSATL,YPTR,PRINT4
* Insert length
PRINT3 LOCAPV ZPTR,OUTATL,XPTR,PRINT1
* Look for output association
PUTDC ZPTR,DESCR,TPTR Insert output block
BRANCH RETNUL Return
*_
PRINT1 RCALL OUTATL,AUGATL,(OUTATL,TPTR,XPTR),RETNUL
* Add new association pair
*_
PRINT4 MOVD ZPTR,DFLFST Set up standard default
PRINT2 RCALL TPTR,BLOCK,IOBLSZ Allocate block
PUTDC TPTR,DESCR,YPTR Insert unit
PUTDC TPTR,2*DESCR,ZPTR Insert format
BRANCH PRINT3 Rejoin processing
*_
PRINT5 SETAC YPTR,UNITO Set default unit
BRANCH PRINT6 Join processing
*_
*---------------------------------------------------------------------*
*
* BACKSPACE(U), ENDFILE(U), and REWIND(U)
*
BKSPCE PROC , BACKSPACE(N)
SETAC SCL,1 Indicate backspace
BRANCH IOOP
*_
ENFILE PROC BKSPCE ENDFILE(N)
SETAC SCL,2 Indicate end of file
BRANCH IOOP
*_
REWIND PROC BKSPCE REWIND(N)
SETAC SCL,3 Indicate rewind
IOOP PUSH SCL Push indicator
RCALL XCL,INTVAL,,FAIL Evaluate integer argument
ACOMPC XCL,0,,UNTERR,UNTERR
* Reject negative or zero
POP SCL Restore indicator
SELBRA SCL,(,EOP,ROP) Select operation
BKSPCE XCL Backspace unit
BRANCH RETNUL
*_
EOP ENFILE XCL End file unit
BRANCH RETNUL
*_
ROP REWIND XCL Rewind unit
BRANCH RETNUL
*_
*---------------------------------------------------------------------*
*
* DETACH(N)
*
DETACH PROC , DETACH(N)
RCALL XPTR,IND,,FAIL Get name of variable
LOCAPV ZPTR,INATL,XPTR,DTCH1
* Look for input association
PUTDC ZPTR,DESCR,ZEROCL Delete association if there is one
PUTDC ZPTR,2*DESCR,ZEROCL Clear association pointer also
DTCH1 LOCAPV ZPTR,OUTATL,XPTR,RETNUL
* Look for output association
PUTDC ZPTR,DESCR,ZEROCL Delete association is there is one
PUTDC ZPTR,2*DESCR,ZEROCL Clear association pointer also
BRANCH RETNUL Return null value
*_
*---------------------------------------------------------------------*
*
* Input Procedure
*
PUTIN PROC , Input procedure
POP (IO1PTR,IO2PTR) Restore block and variable
GETDC IO3PTR,IO1PTR,DESCR Get unit
GETDC IO1PTR,IO1PTR,2*DESCR
* Get length
RCALL IO4PTR,CONVAR,(IO1PTR)
* Get space for string
LOCSP IOSP,IO4PTR Get specifier
INCRA RSTAT,1 Increment count of reads
STREAD IOSP,IO3PTR,FAIL,COMP5
* Perform read
AEQLC TRIMCL,0,,PUTIN1 Check &INPUT
TRIMSP IOSP,IOSP Trim string
GETLG IO1PTR,IOSP Get length
PUTIN1 ACOMP IO1PTR,MLENCL,INTR8 E3.9.2
VEQLC IO2PTR,K,,PUTIN3 CHECK FOR KEYWORD E3.10.2
RCALL IO1PTR,GNVARS,IO1PTR E3.9.2
* Form variable for string
PUTIN2 PUTDC IO2PTR,DESCR,IO1PTR E3.10.2
RRTURN IO1PTR,2 Return value
PUTIN3 LOCSP XSP,IO1PTR E3.10.2
SPCINT IO1PTR,XSP,INTR1,PUTIN2 E3.10.2
*_
*---------------------------------------------------------------------*
*
* Output Procedure
*
PUTOUT PROC , Output procedure
POP (IO1PTR,IO2PTR) Restore block and value
VEQLC IO2PTR,S,,PUTV Is value STRING?
VEQLC IO2PTR,I,,PUTI Is value INTEGER?
RCALL IO2PTR,DTREP,IO2PTR Get data type representation
GETSPC IOSP,IO2PTR,0 Get specifier
BRANCH PUTVU Join processing
*_
PUTV LOCSP IOSP,IO2PTR Get specifier
PUTVU STPRNT IOKEY,IO1PTR,IOSP Perform print
INCRA WSTAT,1 Increment count of writes
BRANCH RTN1 Return
*_
PUTI INTSPC IOSP,IO2PTR Convert INTEGER to STRING
BRANCH PUTVU Rejoin processing
*_
*---------------------------------------------------------------------*
TITLE 'Tracing Procedures and Functions'
*
* TRACE(V,R,T,F)
*
TRACE PROC , TRACE(V,R,T,F)
RCALL XPTR,IND,,FAIL Get name of variable
PUSH XPTR Save name
RCALL YPTR,VARVAL,,FAIL Get trace type
PUSH YPTR Save type
RCALL WPTR,ARGVAL,,FAIL Get tag
PUSH WPTR Save tag
RCALL ZPTR,VARVAL,,FAIL Get trace function
POP (WPTR,YPTR,XPTR) Restore saved arguments
DEQL YPTR,NULVCL,TRAC5 Is type defaulted??
MOVD YPTR,VALTRS Set up VALUE default
TRAC5 LOCAPV YPTR,TRATL,YPTR,TRAC1
* Look for trace type
GETDC YPTR,YPTR,DESCR Get sub pair list
TRACEP PROC TRACE Subentry for TRACE
GETDC TPTR,YPTR,DESCR Get default function
DEQL ZPTR,NULVCL,,TRAC2 Check for null
RCALL TPTR,FINDEX,(ZPTR) Locate function descriptor
TRAC2 SETAC XSIZ,5*DESCR V3.7
SETVC XSIZ,C Insert CODE data type
RCALL XCL,BLOCK,XSIZ Allocate block for code
MOVBLK XCL,TRCBLK,XSIZ V3.7
SETVC TPTR,2 Set up 2 arguments
PUTDC XCL,1*DESCR,TPTR Insert function descriptor
PUTDC XCL,3*DESCR,XPTR Insert name to be traced
PUTDC XCL,5*DESCR,WPTR Insert tag
GETDC TPTR,YPTR,0 Make entry for proper attribute
AEQLC TPTR,0,,TRAC4
LOCAPT TPTR,TPTR,XPTR,TRAC3
* Locate trace
PUTDC TPTR,2*DESCR,XCL Insert new code block
BRANCH RETNUL Return
*_
TRAC3 RCALL TPTR,AUGATL,(TPTR,XPTR,XCL)
* Augment pair list for new entry
TRAC6 PUTDC YPTR,0,TPTR Link in new pair list
BRANCH RETNUL Return
*_
TRAC1 DEQL YPTR,FUNTCL,INTR30 Is type FUNCTION?
MOVD YPTR,TFNCLP Set up CALL trace
RCALL ,TRACEP,,(INTR10,INTR10)
* Call subentry to do it
MOVD YPTR,TFNRLP Set up RETURN trace
BRANCH TRACEP Branch to subentry to do it
*_
TRAC4 RCALL TPTR,BLOCK,TWOCL Allocate new pair list
PUTDC TPTR,DESCR,XPTR Insert name to be traced
PUTDC TPTR,2*DESCR,XCL Insert pointer to pseudo-code
BRANCH TRAC6
*_
*---------------------------------------------------------------------*
*
* STOPTR(N,T)
*
STOPTR PROC , STOPTR(T,R)
RCALL XPTR,IND,,FAIL Get name of variable
PUSH XPTR Save name
RCALL YPTR,VARVAL,,FAIL Get trace respect
POP XPTR
DEQL YPTR,NULVCL,STOPT2 Check for defaulted respect
MOVD YPTR,VALTRS Set up VALUE as default
STOPT2 LOCAPV YPTR,TRATL,YPTR,STOPT1
* Look for trace respect
GETDC YPTR,YPTR,DESCR Get pointer to trace list
STOPTP PROC STOPTR Subentry for FUNCTION
GETDC YPTR,YPTR,0 Get trace list
LOCAPT YPTR,YPTR,XPTR,FAIL Look for traced variable
PUTDC YPTR,DESCR,ZEROCL Zero the entry
PUTDC YPTR,2*DESCR,ZEROCL Overwrite trace
BRANCH RETNUL Return
*_
STOPT1 DEQL YPTR,FUNTCL,INTR30 Check for FUNCTION
MOVD YPTR,TFNCLP Set up CALL
RCALL ,STOPTP,,(FAIL,INTR10)
* Call subprocedure
MOVD YPTR,TFNRLP Set up RETURN
BRANCH STOPTP Branch to subentry
*_
*---------------------------------------------------------------------*
*
* Call Tracing
*
FENTR PROC , Procedure to trace on CALL
RCALL WPTR,VARVAL,,FAIL Get argument
FENTR3 SETLC PROTSP,0 Clear specifier
APDSP PROTSP,TRSTSP Append trace message
INTSPC XSP,STNOCL Convert &STNO to string
APDSP PROTSP,XSP Append &STNO
APDSP PROTSP,COLSP Append colon
APDSP PROTSP,TRLVSP Append level message
INTSPC XSP,LVLCL Convert &FNCLEVEL to string
APDSP PROTSP,XSP Append &FNCLEVEL
APDSP PROTSP,TRCLSP Append call message
LOCSP XSP,WPTR Get specifier for argument
GETLG TCL,XSP Get length
ACOMPC TCL,BUFLEN,FXOVR,FXOVR
* Check for excessively long string
APDSP PROTSP,XSP Append function name
APDSP PROTSP,LPRNSP Append left parenthesis
SETAC WCL,0 Set argument count to 0
FNTRLP INCRA WCL,1 Increment argument count
RCALL ZPTR,ARGINT,(WPTR,WCL),(FENTR4,INTR10)
* Get argument
GETDC ZPTR,ZPTR,DESCR Get value
VEQLC ZPTR,S,,DEFTV Is it STRING?
VEQLC ZPTR,I,,DEFTI Is it INTEGER?
RCALL A2PTR,DTREP,ZPTR Get data type representation
GETSPC XSP,A2PTR,0 Get specifier
GETLG SCL,XSP Get length
SUM TCL,TCL,SCL Total length
ACOMPC TCL,BUFLEN,FXOVR,FXOVR
* Check for excessively long string
DEFTIA APDSP PROTSP,XSP Append value
BRANCH DEFDTT Continue with next argument
*_
DEFTI INTSPC XSP,ZPTR Convert INTEGER to STRING
BRANCH DEFTIA Rejoin processing
*_
DEFTV LOCSP XSP,ZPTR Get specifier
GETLG SCL,XSP Get length
SUM TCL,TCL,SCL Get total length
ACOMPC TCL,BUFLEN,FXOVR,FXOVR
* Check for excessively long string
APDSP PROTSP,QTSP Append quote
APDSP PROTSP,XSP Append value
APDSP PROTSP,QTSP Append quote
DEFDTT APDSP PROTSP,CMASP Append comma
BRANCH FNTRLP Continue processing
*_
FENTR4 AEQLC WCL,1,,FENTR5 Leave paren if no arguments
SHORTN PROTSP,1 Delete last comma
FENTR5 APDSP PROTSP,RPRNSP Append right parenthesis
MSTIME ZPTR Get time
SUBTRT ZPTR,ZPTR,ETMCL Compute elapsed time
INTSPC XSP,ZPTR Convert to STRING
APDSP PROTSP,ETIMSP Append time message
APDSP PROTSP,XSP Append time
STPRNT IOKEY,OUTBLK,PROTSP Print trace message
BRANCH RTNUL3 Return
*_
FENTR2 PROC FENTR Standard entry
POP WPTR Restore function name
BRANCH FENTR3
*_
FXOVR OUTPUT OUTPUT,PRTOVF Print error message
BRANCH RTNUL3 Return
*_
*---------------------------------------------------------------------*
*
* Keyword and Label Tracing
*
KEYTR PROC , Procedure to trace keywords
SETAC FNVLCL,1 Set entry indicator
RCALL WPTR,VARVAL,,FAIL Get keyword
LOCSP XSP,WPTR Get specifier
RCALL YCL,KEYT,(WPTR),(INTR10,)
* Get value of keyword
KEYTR3 SETLC PROTSP,0 Clear specifier
APDSP PROTSP,TRSTSP Append trace message
INTSPC TSP,STNOCL Convert &STNO to string
APDSP PROTSP,TSP Append &STNO
APDSP PROTSP,COLSP Append colon
AEQLC FNVLCL,0,,KEYTR4 Check entry indicator
APDSP PROTSP,AMPSP Append ampersand
KEYTR4 APDSP PROTSP,XSP Append name of keyword
APDSP PROTSP,BLSP Append blank
AEQLC FNVLCL,0,,KEYTR5 Check entry indicator
INTSPC YSP,YCL Convert keyword value to string
APDSP PROTSP,EQLSP Append equal sign
KEYTR5 APDSP PROTSP,YSP Append value
MSTIME YPTR Get time
SUBTRT YPTR,YPTR,ETMCL Compute elapsed time
INTSPC XSP,YPTR Convert time to string
APDSP PROTSP,ETIMSP Append time message
APDSP PROTSP,XSP Append time
STPRNT IOKEY,OUTBLK,PROTSP Print trace message
BRANCH RTN2 Return
*_
LABTR PROC KEYTR Procedure to trace labels
SETAC FNVLCL,0 Set entry indicator
RCALL YPTR,VARVAL,,FAIL Get label name
LOCSP YSP,YPTR Get specifier
SETSP XSP,XFERSP Set up message specifier
BRANCH KEYTR3 Join common processing
*_
*---------------------------------------------------------------------*
*
* Trace Handler
*
TRPHND PROC , Trace handling procedure
POP ATPTR Restore trace
DECRA TRAPCL,1 Decrement &TRACE
PUSH (LSTNCL,STNOCL,FRTNCL,OCBSCL,OCICL,TRAPCL,TRACL)
* Save system descriptors
GETDC OCBSCL,ATPTR,2*DESCR NEW CODE BASE
* Get new code base
SETAC OCICL,DESCR Set up offset
GETD XPTR,OCBSCL,OCICL Get function descriptor
SETAC TRAPCL,0 Set &TRACE to 0
SETAC TRACL,0 Set &FTRACE to 0
RCALL ,INVOKE,XPTR,(,) E3.3.1
* Evaluate function
POP (TRACL,TRAPCL,OCICL,OCBSCL,FRTNCL,STNOCL,LSTNCL)
* Restore system descriptors
BRANCH RTN1 E3.3.1
*_
*---------------------------------------------------------------------*
*
* Value Tracing
*
VALTR PROC , Tracing procedures
SETAC FNVLCL,1 Note entry
VALTR2 RCALL XPTR,IND,,FAIL Get variable to be traced
PUSH XPTR Save name
RCALL ZPTR,VARVAL,,FAIL Get tag
POP XPTR Restore variable
VALTR4 SETLC TRACSP,0 Clear specifier
APDSP TRACSP,TRSTSP Append trace message
INTSPC XSP,STNOCL Convert &STNO to string
APDSP TRACSP,XSP Append &STNO
APDSP TRACSP,COLSP Append colon
AEQLC FNVLCL,0,,FNEXT1 Check entry indicator
VEQLC XPTR,S,DEFDT Is variable a string?
VALTR3 LOCSP XSP,XPTR Get specifier
GETLG TCL,XSP Get length
ACOMPC TCL,BUFLEN,VXOVR,VXOVR
* Check for excessively long name
VALTR1 APDSP TRACSP,XSP Append name of variable
APDSP TRACSP,BLEQSP Append ' = '
GETDC YPTR,XPTR,DESCR Get value of traced variable
VEQLC YPTR,S,,TRV Is it STRING?
VEQLC YPTR,I,,TRI Is it INTEGER?
RCALL XPTR,DTREP,YPTR Else get data type representation
GETSPC XSP,XPTR,0 Get specifier
TRI2 APDSP TRACSP,XSP Append value
BRANCH TRPRT Join common processing
*_
TRV LOCSP XSP,YPTR Get specifier
GETLG SCL,XSP Get length
SUM TCL,TCL,SCL Compute total length
ACOMPC TCL,BUFLEN,VXOVR,VXOVR
* Check for excessively long message
APDSP TRACSP,QTSP Append quote
APDSP TRACSP,XSP Append string
APDSP TRACSP,QTSP Append quote
TRPRT MSTIME YPTR Get time
SUBTRT YPTR,YPTR,ETMCL Compute time in interpreter
INTSPC XSP,YPTR Convert to STRING
APDSP TRACSP,ETIMSP Append time message
APDSP TRACSP,XSP Append time
STPRNT IOKEY,OUTBLK,TRACSP Print trace message
BRANCH RTNUL3 Return
*_
TRI INTSPC XSP,YPTR Convert INTEGER to STRING
BRANCH TRI2 Join processing
*_
DEFDT LOCSP XSP,ZPTR Get specifier for tag
BRANCH VALTR1 Join processing
*_
FNEXTR PROC VALTR Return tracing procedure
SETAC FNVLCL,0 Note entry
BRANCH VALTR2 Join processing
*_
FNEXT1 APDSP TRACSP,TRLVSP Append level message
MOVD XCL,LVLCL Copy &FNCLEVEL
DECRA XCL,1 Decrement
INTSPC XSP,XCL Convert to STRING
APDSP TRACSP,XSP Append function level
APDSP TRACSP,BLSP Append blank
LOCSP XSP,RETPCL Get specifier for return
APDSP TRACSP,XSP Append return type
APDSP TRACSP,OFSP Append ' OF '
DEQL RETPCL,FRETCL,VALTR3
* Check for FRETURN
LOCSP XSP,XPTR Get specifier for function name
GETLG TCL,XSP Get length
ACOMPC TCL,BUFLEN,VXOVR,VXOVR
* Check for excessively long string
APDSP TRACSP,XSP Append name of function
BRANCH TRPRT Join common processing
*_ FTRACE call trace
FNEXT2 PROC VALTR Note entry
SETAC FNVLCL,0 Restore function name
POP XPTR Join common processing
BRANCH VALTR4
*_
VXOVR OUTPUT OUTPUT,PRTOVF Print error message
BRANCH RTNUL3 Return
*_
*---------------------------------------------------------------------*
TITLE 'Other Operations'
*
* Assignment
*
ASGN PROC , X = Y
INCRA OCICL,DESCR Increment offset in object code
GETD XPTR,OCBSCL,OCICL Get object code descriptor
TESTF XPTR,FNC,,ASGNC Test for function descriptor
ASGNV VEQLC XPTR,K,,ASGNIC Check for keyword subject
INCRA OCICL,DESCR Increment offset in object code
GETD YPTR,OCBSCL,OCICL Get object code descriptor
TESTF YPTR,FNC,,ASGNCV Test for function descriptor
ASGNVN AEQLC INSW,0,,ASGNV1 Check &INPUT
LOCAPV ZPTR,INATL,YPTR,ASGNV1
* Look for input association
GETDC ZPTR,ZPTR,DESCR Get input association descriptor
RCALL YPTR,PUTIN,(ZPTR,YPTR),(FAIL,ASGNVV)
*_
ASGNV1 GETDC YPTR,YPTR,DESCR Get value
ASGNVV PUTDC XPTR,DESCR,YPTR Perform assignment
AEQLC OUTSW,0,,ASGN1 Check &OUTPUT
LOCAPV ZPTR,OUTATL,XPTR,ASGN1
* Look for output association
GETDC ZPTR,ZPTR,DESCR Get output association descriptor
RCALL ,PUTOUT,(ZPTR,YPTR) Perform output
ASGN1 ACOMPC TRAPCL,0,,RTNUL3,RTNUL3
* Check &TRACE
LOCAPT ATPTR,TVALL,XPTR,RTNUL3
* Look for VALUE trace
RCALL ,TRPHND,ATPTR,RTNUL3 E3.3.1
*_
ASGNC RCALL XPTR,INVOKE,(XPTR),(FAIL,ASGNV,NEMO)
*_
ASGNCV PUSH XPTR Save subject of assignment
RCALL YPTR,INVOKE,(YPTR),(FAIL,ASGNVP)
ASGNCJ POP XPTR Restore subject
BRANCH ASGNVV
*_
ASGNVP POP XPTR Restore subject
BRANCH ASGNVN
*_
ASGNIC PUSH XPTR Save subject of assignment
RCALL YPTR,INTVAL,,(FAIL,ASGNCJ)
* Get integer value for keyword
*_
*---------------------------------------------------------------------*
*
* X Y (concatenation)
*
CON PROC , X Y (concatenation)
RCALL ,XYARGS,,FAIL Get two arguments
DEQL XPTR,NULVCL,,RTYPTR If first is null, return second
DEQL YPTR,NULVCL,,RTXPTR If second is null, return first
VEQLC XPTR,S,,CON5 Is first STRING?
VEQLC XPTR,P,,CON5 Is first PATTERN?
VEQLC XPTR,I,,CON4I Is first INTEGER?
VEQLC XPTR,R,,CON4R Is first REAL?
VEQLC XPTR,E,INTR1 Is first EXPRESSION?
RCALL TPTR,BLOCK,STARSZ Allocate block for pattern
MOVBLK TPTR,STRPAT,STARSZ Set up pattern for expression
PUTDC TPTR,4*DESCR,XPTR Insert pointer to expression
MOVD XPTR,TPTR Set up as first argument
BRANCH CON5
*_
CON4R REALST REALSP,XPTR Convert REAL to STRING
SETSP XSP,REALSP Set up specifier
RCALL XPTR,GENVAR,XSPPTR,CON5
* Generate variable
*_
CON4I INTSPC ZSP,XPTR Convert INTEGER to STRING
RCALL XPTR,GENVAR,(ZSPPTR)
* Generate variable
CON5 VEQLC YPTR,S,,CON7 Is second STRING?
VEQLC YPTR,P,,CON7 Is second PATTERN?
VEQLC YPTR,I,,CON5I Is second INTEGER?
VEQLC YPTR,R,,CON5R Is second REAL?
VEQLC YPTR,E,INTR1 Is second EXPRESSION?
RCALL TPTR,BLOCK,STARSZ Allocate block for pattern
MOVBLK TPTR,STRPAT,STARSZ Set up pattern for expression
PUTDC TPTR,4*DESCR,YPTR Insert pointer to expression
MOVD YPTR,TPTR Set up as second argument
BRANCH CON7 Join processing
*_
CON5R REALST REALSP,YPTR Convert REAL to STRING
SETSP YSP,REALSP Set up sepcifier
RCALL YPTR,GENVAR,YSPPTR,CON7
* Generate variable
*_
CON5I INTSPC ZSP,YPTR Convert INTEGER to STRING
RCALL YPTR,GENVAR,(ZSPPTR)
* Generate variable
CON7 SETAV DTCL,XPTR Get data type of first
MOVV DTCL,YPTR Get data type of second
DEQL DTCL,VVDTP,,CONVV Check for STRING-STRING
DEQL DTCL,VPDTP,,CONVP Check for STRING-PATTERN
DEQL DTCL,PVDTP,,CONPV Check for PATTERN-STRING
DEQL DTCL,PPDTP,INTR1,CONPP
* Check for PATTERN-PATTERN
*_
CONVV LOCSP XSP,XPTR Specifier for first string
LOCSP YSP,YPTR Specifier for second string
GETLG XCL,XSP Length of first string
GETLG YCL,YSP Length of second string
SUM XCL,XCL,YCL Total length
ACOMP XCL,MLENCL,INTR8 Check against &MAXLNGTH
RCALL ZPTR,CONVAR,(XCL) Allocate space for string
LOCSP TSP,ZPTR Get specifier to allocated space
SETLC TSP,0 Clear length
APDSP TSP,XSP Move in first string
APDSP TSP,YSP Append second string
BRANCH GENVSZ Generate variable
*_
CONVP LOCSP TSP,XPTR Specifier to string
GETLG TMVAL,TSP Get length of string
RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern
MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR
* Construct pattern
CONPP GETSIZ XSIZ,XPTR Get size of first pattern
GETSIZ YSIZ,YPTR Get size of second pattern
SUM TSIZ,XSIZ,YSIZ Compute total size required
SETVC TSIZ,P Insert PATTERN data type
RCALL TPTR,BLOCK,TSIZ Allocate block for new pattern
MOVD ZPTR,TPTR Save copy to return
LVALUE TVAL,YPTR Get least value for second pattern
CPYPAT TPTR,XPTR,TVAL,ZEROCL,XSIZ,XSIZ
* Copy in first pattern
CPYPAT TPTR,YPTR,ZEROCL,XSIZ,ZEROCL,YSIZ
* Copy in second pattern
BRANCH RTZPTR Return pattern as value
*_
CONPV LOCSP TSP,YPTR Get specifier to string
GETLG TMVAL,TSP Get length of string
RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern
MAKNOD YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR
* Construct pattern for string
BRANCH CONPP Join common processinANVP RT---------------------------------------------------------------------*
*
* Indirect Reference
*
IND PROC , $X
RCALL XPTR,ARGVAL,,FAIL Get argument
VEQLC XPTR,S,,INDV STRING is acceptable
VEQLC XPTR,N,,RTXNAM NAME can be returned directly
VEQLC XPTR,I,,GENVIX Convert INTEGER
VEQLC XPTR,K,INTR1,RTXNAM KEYWORD is like NAME
*_
INDV AEQLC XPTR,0,RTXNAM,NONAME
* Be sure string is not null
*_
*---------------------------------------------------------------------*
*
* Keywords
*
KEYWRD PROC , &X
INCRA OCICL,DESCR Increment offset
GETD XPTR,OCBSCL,OCICL Get object code descriptor
TESTF XPTR,FNC,,KEYC Check for function
KEYN LOCAPV XPTR,KNATL,XPTR,KEYV
* Look up X on unprotected list
SETVC XPTR,K Set KEYWORD (NAME) data type
BRANCH RTXNAM Return by name
*_
KEYV LOCAPV ATPTR,KVATL,XPTR,UNKNKW
* Look up X on protected list
GETDC ZPTR,ATPTR,DESCR Get value
BRANCH RTZPTR Return by value
*_
KEYC RCALL XPTR,INVOKE,(XPTR),(FAIL,KEYN,NEMO)
* Evaluate computed keyword
*_
KEYT PROC KEYWRD Procedure to get keyword for trace
POP XPTR Restore argument
BRANCH KEYN
*_ Join common processing
*---------------------------------------------------------------------*
* Literal Evaluation
*
*
LIT PROC , 'X'
INCRA OCICL,DESCR Increment offset
GETD ZPTR,OCBSCL,OCICL Get object code descriptor
BRANCH RTZPTR Return value
*_
*---------------------------------------------------------------------*
*
* Unary Name Operator
*
NAME PROC , .X
INCRA OCICL,DESCR Increment offset
GETD ZPTR,OCBSCL,OCICL Get object code descriptor
TESTF ZPTR,FNC,RTZPTR Test for function
RCALL ZPTR,INVOKE,ZPTR,(FAIL,RTZPTR,NEMO)
*_
*
*
*---------------------------------------------------------------------*
*
* Value Assignment in Pattern Matching
*
NMD PROC ,
MOVD TCL,NHEDCL
NMD1 ACOMP TCL,NAMICL,INTR13,RTN2
* Check for end
SUM TPTR,NBSPTR,TCL Compute address
GETSPC TSP,TPTR,DESCR Get specifier
GETDC TVAL,TPTR,DESCR+SPEC
* get variable
GETLG XCL,TSP Get length
ACOMP XCL,MLENCL,INTR8 Check &MAXLNGTH
VEQLC TVAL,E,,NAMEXN Is Variable EXPRESSION?
NMD5 VEQLC TVAL,K,,NMDIC Is variable KEYWORD?
RCALL VVAL,GENVAR,(TSPPTR)
* Generate string
NMD4 PUTDC TVAL,DESCR,VVAL Assign value
AEQLC OUTSW,0,,NMD3 Check &OUTPUT
LOCAPV ZPTR,OUTATL,TVAL,NMD3
* Look for output association
GETDC ZPTR,ZPTR,DESCR Get association
RCALL ,PUTOUT,(ZPTR,VVAL) Perform output
NMD3 ACOMPC TRAPCL,0,,NMD2,NMD2 Check &TRACE
LOCAPT ATPTR,TVALL,TVAL,NMD2
* Look for VALUE trace
PUSH (TCL,NAMICL,NHEDCL) Save state
MOVD NHEDCL,NAMICL Set up new name list
RCALL ,TRPHND,ATPTR E3.3.1
* Perform trace
POP (NHEDCL,NAMICL,TCL) Restore state
NMD2 INCRA TCL,DESCR+SPEC Move to next name
BRANCH NMD1 Continue
*_
NMDIC SPCINT VVAL,TSP,INTR1,NMD4 Convert to INTEGER
*_
NAMEXN RCALL TVAL,EXPEVL,TVAL,(FAIL,NMD5,NEMO) E3.10.5
* Evaluate expression
*_
*---------------------------------------------------------------------*
*
* Unevaluated Expression
*
STR PROC , *X
SUM ZPTR,OCBSCL,OCICL Compute position in code
RCALL ,CODSKP,(ONECL) Skip one nest
SETVC ZPTR,E Insert EXPRESSION data type
BRANCH RTZPTR Return pointer to code
*_
*---------------------------------------------------------------------*
TITLE 'Other Predicates'
*
* DIFFER(X,Y)
*
DIFFER PROC , DIFFER(X,Y)
RCALL ,XYARGS,,FAIL Evaluate arguments
DEQL XPTR,YPTR,RETNUL,FAIL
* Compare them
*_
*---------------------------------------------------------------------*
*
* IDENT(X,Y)
*
IDENT PROC , IDENT(X,Y)
RCALL ,XYARGS,,FAIL Evaluate arguments
DEQL XPTR,YPTR,FAIL,RETNUL
* Compare arguments
*_
*---------------------------------------------------------------------*
*
* LGT(X,Y)
*
LGT PROC , LGT(X,Y)
RCALL XPTR,VARVAL,,FAIL Evaluate first argument
PUSH XPTR Save first argument
RCALL YPTR,VARVAL,,FAIL Evaluate second argument
POP XPTR Restore first argument
AEQLC XPTR,0,,FAIL Null is not greater than anything
AEQLC YPTR,0,,RETNUL Similarly for second argument
LOCSP XSP,XPTR Get specifier to first argument
LOCSP YSP,YPTR Get specifier to second argument
LEXCMP XSP,YSP,RETNUL,FAIL,FAIL
* Compare lexically
*_
*---------------------------------------------------------------------*
*
* Unary Negation Operator
*
NEG PROC , \X
PUSH (OCBSCL,OCICL) Save object code position
RCALL ,ARGVAL,,(,FAIL) Fail on success
POP (OCICL,OCBSCL) Restore object code position
RCALL ,CODSKP,(ONECL),RETNUL
* Skip argument and return
*_
*---------------------------------------------------------------------*
*
* Unary Interrogation Operator
*
QUES PROC , ?X
RCALL ,ARGVAL,,(FAIL,RETNUL)
* Evaluate argument
*_
*---------------------------------------------------------------------*
TITLE 'Other Functions'
*
* APPLY(F,A1,...AN)
*
APPLY PROC , APPLY(F,A1,...,AN)
SETAV XCL,INCL Get count of arguments
DECRA XCL,1 Decrement to skip function name
ACOMPC XCL,1,,,ARGNER E3.3.3
PUSH XCL Save argument count
RCALL XPTR,VARVAL,,FAIL Get function name
POP XCL Restore argument count
LOCAPV XPTR,FNCPL,XPTR,UNDF
* Locate function
GETDC INCL,XPTR,DESCR Get function descriptor
SETVA INCL,XCL Insert actual number of arguments
RCALL ZPTR,INVOKE,(INCL),(FAIL,,RTZPTR)
MOVD XPTR,ZPTR Return by name
BRANCH RTXNAM
*_
*---------------------------------------------------------------------*
*
* ARG(F,N), FIELD(F,N), and LOCAL(F,N)
*
ARG PROC , ARG(F,N)
PUSH (ONECL,DEFCL) Save ARG indicators
BRANCH ARG1 Join main processing
*_
ARGINT PROC ARG Procedure used for CALL tracing
POP (XPTR,XCL) Restore arguments
PUSH (ONECL,DEFCL) Save indicators
BRANCH ARG2 Join processing
*_
LOCAL PROC ARG LOCAL(F,N)
PUSH (ONECL,ZEROCL,DEFCL)
* Save LOCAL indicators
BRANCH ARG1 Join main processing
*_
FIELDS PROC ARG FIELD(F,N)
PUSH (ZEROCL,ZEROCL,DATCL)
* Save FIELD indicators
ARG1 RCALL XPTR,VARVAL,,FAIL Get function name
PUSH XPTR Save function name
RCALL XCL,INTVAL,,FAIL Get number
ACOMP ZEROCL,XCL,FAIL,FAIL
* Verify positive number
POP XPTR Restore function name
ARG2 LOCAPV XPTR,FNCPL,XPTR,INTR30
* Look for function descriptor
GETDC XPTR,XPTR,DESCR Get function descriptor
GETDC YCL,XPTR,0 Get procedure descriptor
GETDC XPTR,XPTR,DESCR Get definition block
POP (ZCL,ALCL) Restore indicators
AEQL YCL,ZCL,INTR30 Check procedure type
MULTC XCL,XCL,DESCR Convert number to address units
INCRA XCL,2*DESCR Skip prototype information
SETAV YCL,YCL Get argument count
MULTC YCL,YCL,DESCR Convert to address units
AEQLC ALCL,0,,ARG4 Check funcion type
INCRA YCL,2*DESCR Increment for heading
MOVD ZCL,YCL Get working copy
BRANCH ARG5 Branch to continue processing
*_
ARG4 GETSIZ ZCL,XPTR Get size of block
POP ALCL Restore entry indicator
AEQLC ALCL,0,,ARG5 Check entry type
SUM XCL,XCL,YCL Skip formal arguments
ARG5 ACOMP XCL,ZCL,FAIL Check number in bounds
GETD ZPTR,XPTR,XCL Get the desired name
BRANCH RTZPTR Return name as value
*_
*---------------------------------------------------------------------*
*
* CLEAR()
*
CLEAR PROC , CLEAR()
RCALL ,ARGVAL,,FAIL Get rid of argument
SETAC DMPPTR,OBLIST-DESCR Initialize bin pointer
CLEAR1 ACOMP DMPPTR,OBEND,RETNUL Check for end
INCRA DMPPTR,DESCR Update for next bin
MOVD YPTR,DMPPTR Get working copy
CLEAR2 GETAC YPTR,YPTR,LNKFLD Get next variable
AEQLC YPTR,0,,CLEAR1 Check for end of chain
PUTDC YPTR,DESCR,NULVCL Assign null value
BRANCH CLEAR2 Continue
*_
*---------------------------------------------------------------------*
*
* COLLECT(N)
*
COLECT PROC , COLLECT(N)
RCALL XPTR,INTVAL,,FAIL Get number of address units required
ACOMPC XPTR,0,,,LENERR Verify positive integer
RCALL ZPTR,GC,(XPTR),FAIL Call for storage regeneration
SETVC ZPTR,I Set INTEGER data type
BRANCH RTZPTR Return amount collected
*_
*---------------------------------------------------------------------*
*
* COPY(X)
*
COPY PROC , COPY(X)
RCALL XPTR,ARGVAL,,FAIL Get object to copy
VEQLC XPTR,S,,INTR1 STRING cannot be copied
VEQLC XPTR,I,,INTR1 INTEGER cannot be copied
VEQLC XPTR,R,,INTR1 REAL cannot be copied
VEQLC XPTR,N,,INTR1 NAME cannot be copied
VEQLC XPTR,K,,INTR1 KEYWORD (NAME) cannot be copied
VEQLC XPTR,E,,INTR1 EXPRESSION cannot be copied
VEQLC XPTR,T,,INTR1 TABLE cannot be copied
GETSIZ XCL,XPTR Get size of object to copy
MOVV XCL,XPTR Insert data type
RCALL ZPTR,BLOCK,XCL Allocate block for copy
MOVBLK ZPTR,XPTR,XCL Copy contents
BRANCH RTZPTR Return the copy
*_
*---------------------------------------------------------------------*
*
* CONVERT(X,T)
*
CNVRT PROC , CONVERT(X,T)
RCALL ZPTR,ARGVAL,,FAIL Get object to be converted
PUSH ZPTR Save object
RCALL YPTR,VARVAL,,FAIL Get data type target
POP ZPTR Restore object
LOCAPV XPTR,DTATL,YPTR,INTR1
* Look for data type code
GETDC XPTR,XPTR,DESCR Get code
SETAV DTCL,ZPTR Insert object data type
MOVV DTCL,XPTR Insert target data type
DEQL DTCL,IVDTP,,CNVIV Check for INTEGER-STRING
DEQL DTCL,VCDTP,,RECOMP Check for STRING-CODE
DEQL DTCL,VEDTP,,CONVE
DEQL DTCL,VRDTP,,CONVR Check for STRING-REAL
DEQL DTCL,RIDTP,,CONRI Check for REAL-INTEGER
DEQL DTCL,IRDTP,,CONIR Check for INTEGER-REAL
DEQL DTCL,VIDTP,,CNVVI CHeck for STRING-INTEGER
DEQL DTCL,ATDTP,,CNVAT Check for ARRAY-TABLE
DEQL DTCL,TADTP,,CNVTA Check for TABLE-ARRAY
VEQL ZPTR,XPTR,,RTZPTR E3.0.4
VEQLC XPTR,S,FAIL,CNVRTS E3.0.4
* Check for idem-conversion
*_
RECOMP SETAC SCL,1 Note STRING-CODE conversion
RECOMJ LOCSP TEXTSP,ZPTR Set up global specifier
RECOMT GETLG OCALIM,TEXTSP E3.1.5
AEQLC OCALIM,0,,RECOMN E3.1.5
MULTC OCALIM,OCALIM,DESCR Convert to address units
INCRA OCALIM,6*DESCR Leave room for safety
SETVC OCALIM,C Insert CODE data type
RCALL CMBSCL,BLOCK,OCALIM Allocate block for object code
SUM OCLIM,CMBSCL,OCALIM Compute end
DECRA OCLIM,6*DESCR
SETAC CMOFCL,0 Zero offset
SETAC ESAICL,0 Zero error count
PUSH CMBSCL Save block pointer
SELBRA SCL,(,CONVEX) Select correct procedure
RECOM1 LEQLC TEXTSP,0,,RECOM2 Is string exhausted?
RCALL ,CMPILE,,(RECOMF,,RECOM1)
* Compile statement
RECOM2 SETAC SCL,3 Set return switch
RECOMQ INCRA CMOFCL,DESCR Increment offset
PUTD CMBSCL,CMOFCL,ENDCL Insert END function
POP ZPTR Restore pointer to code block
RECOMZ SUM CMBSCL,CMBSCL,CMOFCL
* Compute used portion of block
RCALL ,SPLIT,(CMBSCL) Split off remainder
SETAC OCLIM,0 Clear limit pointer
SETAC LPTR,0 Clear label pointer
ZERBLK COMREG,COMDCT Zero compiler descriptors
SELBRA SCL,(FAIL,INTR10,RTZPTR)
* Select return
*_
RECOMF SETAC SCL,1 Set failure return
BRANCH RECOMQ Rejoin processing
*_
RECOMN SETSP TEXTSP,BLSP E3.1.5
BRANCH RECOMT E3.1.5
*_ E3.1.5
CODER PROC CNVRT CODE(S)
RCALL ZPTR,VARVAL,,(FAIL,RECOMP)
* Get argument
*_
CONVE PROC CNVRT Convert to EXPRESSION
SETAC SCL,2 Set switch
BRANCH RECOMJ Join common program
*_
CONVEX RCALL FORMND,EXPR,,FAIL Compile expression
LEQLC TEXTSP,0,FAIL Verify complete compilation
RCALL ,TREPUB,FORMND Publish code tree
MOVD ZPTR,CMBSCL E3.1.6
SETVC ZPTR,E Insert EXPRESSION data type
SETAC SCL,3 Set return branch
BRANCH RECOMZ Join common program
*_
CONVR LOCSP ZSP,ZPTR Get specifier
SPCINT ZPTR,ZSP,,CONIR Try conversion to INTEGER first
SPREAL ZPTR,ZSP,FAIL,RTZPTR
* Convert to REAL
*_
CONIR INTRL ZPTR,ZPTR Convert INTEGER to REAL
BRANCH RTZPTR Return value
*_
CONRI RLINT ZPTR,ZPTR,FAIL,RTZPTR
* Convert REAL to INTEGER
*_
CNVIV RCALL ZPTR,GNVARI,ZPTR,RTZPTR
* Convert INTEGER to STRING
*_
CNVVI LOCSP ZSP,ZPTR Get specifier
SPCINT ZPTR,ZSP,,RTZPTR Convert STRING to INTEGER
SPREAL ZPTR,ZSP,FAIL,CONRI Try conversion to REAL
*_
CNVRTS RCALL XPTR,DTREP,ZPTR Get data type representation
GETSPC ZSP,XPTR,0 Get specifier
BRANCH GENVRZ Go generate variable
*_
CNVTA MOVD YPTR,ZPTR E3.2.3
MOVD YCL,ZEROCL E3.2.3
CNVTA7 GETSIZ XCL,YPTR E3.2.3
MOVD WPTR,YPTR E3.2.3
MOVD ZCL,XCL E3.2.3
DECRA XCL,3*DESCR E3.2.3
CNVTA1 GETD WCL,WPTR,XCL Get item value
DEQL WCL,NULVCL,,CNVTA2 Check for null value
INCRA YCL,1 Otherwise count item
CNVTA2 AEQLC XCL,DESCR,,CNVTA6 E3.2.3
DECRA XCL,2*DESCR Count down
BRANCH CNVTA1 Process next item
*_
CNVTA6 GETD YPTR,YPTR,ZCL E3.2.3
AEQLC YPTR,1,CNVTA7 E3.2.3
CNVTA4 AEQLC YCL,0,,FAIL Fail on empty table
MOVD WPTR,ZPTR E3.2.3
MULTC XCL,YCL,2*DESCR Convert count to address units
INTSPC YSP,YCL Get prototype for size
SETLC PROTSP,0 Clear specifier
APDSP PROTSP,YSP Append length
APDSP PROTSP,CMASP Append comma
MOVD WCL,ZEROCL E3.1.1
SETAC WCL,2 Set up 2 for second dimension
INTSPC XSP,WCL Convert to string
APDSP PROTSP,XSP Append 2
SETSP XSP,PROTSP Move specifier
RCALL TPTR,GENVAR,XSPPTR E3.5.2
* Generate variable for prototype
MOVD ZCL,XCL Save size
INCRA XCL,4*DESCR Increment for heading
RCALL ZPTR,BLOCK,XCL Get block for array
SETVC ZPTR,A Insert ARRAY data type
MOVD ATPRCL,TPTR E3.5.2
SETVA ATEXCL,YCL Insert First dimension in head
MOVBLK ZPTR,ATRHD,FRDSCL Copy heading information
MOVD YPTR,ZPTR Save copy of block pointer
MULTC YCL,YCL,DESCR Convert item count to address units
INCRA YPTR,5*DESCR Skip heading
SUM TPTR,YPTR,YCL Compute second half position
CNVTA8 GETSIZ WCL,WPTR E3.2.3
DECRA WCL,2*DESCR E3.2.3
SUM WCL,WPTR,WCL E3.2.3
CNVTA3 GETDC TCL,WPTR,DESCR E3.2.3
DEQL TCL,NULVCL,,CNVTA5 E3.2.3
PUTDC TPTR,0,TCL E3.2.3
MOVDIC YPTR,0,WPTR,2*DESCR
INCRA YPTR,DESCR Increment upper pointer
INCRA TPTR,DESCR Increment lower pointer
CNVTA5 INCRA WPTR,2*DESCR
AEQL WCL,WPTR,CNVTA3 E3.2.3
GETDC WPTR,WCL,2*DESCR E3.2.3
AEQLC WPTR,1,CNVTA8 E3.8.1
SETAC TPTR,0 E3.8.1
BRANCH RTZPTR E3.8.1
*_
CNVAT GETDC XCL,ZPTR,2*DESCR Get array dimensionality
MOVD YPTR,ZPTR Save copy of array pointer
AEQLC XCL,2,FAIL Verify rectangular array
GETDC XCL,ZPTR,3*DESCR Get second dimension
VEQLC XCL,2,FAIL Verify extent of 2
GETSIZ XCL,ZPTR Get size of array block
DECRA XCL,2*DESCR E3.2.3
RCALL XPTR,BLOCK,XCL Allocate block for pair list
SETVC XPTR,T E3.2.3
GETDC YCL,ZPTR,4*DESCR E3.2.3
MOVD ZPTR,XPTR E3.2.3
PUTD XPTR,XCL,ONECL E3.2.3
DECRA XCL,DESCR E3.2.3
MOVD TCL,EXTVAL E3.2.3
INCRA TCL,2*DESCR E3.2.3
PUTD XPTR,XCL,TCL E3.2.3
SETAV YCL,YCL E3.2.3
MULTC YCL,YCL,DESCR E3.2.3
INCRA YPTR,5*DESCR E3.2.3
SUM WPTR,YPTR,YCL E3.2.3
CNVAT2 MOVDIC XPTR,DESCR,WPTR,0 E3.2.3
MOVDIC XPTR,2*DESCR,YPTR,0 E3.2.3
DECRA YCL,DESCR E3.2.3
AEQLC YCL,0,,RTZPTR E3.2.3
INCRA XPTR,2*DESCR Increment pair list pointer
INCRA WPTR,DESCR Increment lower array pointer
INCRA YPTR,DESCR Increment upper array pointer
BRANCH CNVAT2 Continue
*_
*---------------------------------------------------------------------*
*
* DATE()
*
DATE PROC , DATE()
RCALL ,ARGVAL,,FAIL Get rid of argument
DATE ZSP Get the date
BRANCH GENVRZ Go generate the variable
*_
*---------------------------------------------------------------------*
*
* DATATYPE(X)
*
DT PROC , DATATYPE(X)
RCALL A2PTR,ARGVAL,,FAIL Get object
MOVV DT1CL,A2PTR Insert data type
LOCAPT A3PTR,DTATL,DT1CL,DTEXTN
* Look for data type
GETDC A3PTR,A3PTR,2*DESCR Get data type name
DTRTN RRTURN A3PTR,3 Return name
*_
DTEXTN MOVD A3PTR,EXTPTR Set up EXTERNAL data type
BRANCH DTRTN Return
*_
*---------------------------------------------------------------------*
*
* DUMP(N)
*
DMP PROC , DUMP(N)
RCALL XPTR,INTVAL,,FAIL Evaluate argument
AEQLC XPTR,0,,RETNUL No dump if zero
DUMP PROC DMP End game dump procedure
SETAC WPTR,OBLIST-DESCR Initialize bin list pointer
DMPB ACOMP WPTR,OBEND,RETNUL Check for end
INCRA WPTR,DESCR Increment pointer
MOVD YPTR,WPTR Save working copy
DMPA GETAC YPTR,YPTR,LNKFLD Get string structure
AEQLC YPTR,0,,DMPB Check for end of chain
GETDC XPTR,YPTR,DESCR Get value
DEQL XPTR,NULVCL,,DMPA Skip null string values
SETLC DMPSP,0 Clear specifier
LOCSP YSP,YPTR Get specifier for variable
GETLG YCL,YSP Get length
ACOMPC YCL,BUFLEN,DMPOVR,DMPOVR
* Check for excessive length
APDSP DMPSP,YSP Append variable
APDSP DMPSP,BLEQSP Append ' = '
VEQLC XPTR,S,,DMPV STRING is alright
VEQLC XPTR,I,,DMPI Convert INTEGER
RCALL A1PTR,DTREP,XPTR Else get representation
GETSPC YSP,A1PTR,0 Get specifier
DMPX GETLG XCL,YSP Get length
SUM YCL,YCL,XCL Get total
ACOMPC YCL,BUFLEN,DMPOVR Check for excessive length
APDSP DMPSP,YSP Append value
BRANCH DMPRT Go print it
*_
DMPV LOCSP YSP,XPTR Get specifier
GETLG XCL,YSP Get length
SUM YCL,YCL,XCL Total length
ACOMPC YCL,BUFLEN,DMPOVR Check for excessive length
APDSP DMPSP,QTSP Append quote
APDSP DMPSP,YSP Append value
APDSP DMPSP,QTSP Append quote
DMPRT STPRNT IOKEY,OUTBLK,DMPSP Print line
BRANCH DMPA Continue
*_
DMPI INTSPC YSP,XPTR Convert integer
BRANCH DMPX Rejoin processing
*_
DMPOVR OUTPUT OUTPUT,PRTOVF Print error message
BRANCH DMPA Continue
*_
DMK PROC , Procedure to dump keywords
OUTPUT OUTPUT,PKEYF Print caption
GETSIZ XCL,KNLIST Get size of pair list
DMPK1 GETD XPTR,KNLIST,XCL Get name of keyword
DECRA XCL,DESCR Adjust offset
GETD YPTR,KNLIST,XCL Get value of keyword
INTSPC YSP,YPTR Convert integer to string
LOCSP XSP,XPTR Get specifier
SETLC DMPSP,0 Clear specifier
APDSP DMPSP,AMPSP Append ampersand
APDSP DMPSP,XSP Append name
APDSP DMPSP,BLEQSP Append ' = '
APDSP DMPSP,YSP Append value
STPRNT IOKEY,OUTBLK,DMPSP Print line
DECRA XCL,DESCR Adjust offset
AEQLC XCL,0,DMPK1,RTN1 Check for end
*_
*---------------------------------------------------------------------*
*
* DUPL(S,N)
*
DUPL PROC , DUPL(S,N)
RCALL XPTR,VARVAL,,FAIL Get string to duplicate
PUSH XPTR Save string
RCALL YPTR,INTVAL,,FAIL Get duplication factor
POP XPTR Restore string
ACOMPC YPTR,0,,RETNUL,FAIL Return null for 0 duplications
LOCSP XSP,XPTR Get specifier
GETLG XCL,XSP Get length
MULT XCL,XCL,YPTR,AERROR E3.9.3
ACOMP XCL,MLENCL,INTR8 Check &MAXLNGTH
RCALL ZPTR,CONVAR,XCL Allocate space for string
LOCSP TSP,ZPTR Get specifier
SETLC TSP,0 Zero length
DUPL1 APDSP TSP,XSP Append a copy
DECRA YPTR,1 Count down
AEQLC YPTR,0,DUPL1,GENVSZ Check for end
*_
*---------------------------------------------------------------------*
*
* OPSYN(F1,F2,N)
*
OPSYN PROC , OPSYN(F,G,N)
RCALL XPTR,VARVAL,,FAIL Get object function
PUSH XPTR Save object function
RCALL YPTR,VARVAL,,FAIL Get image function
PUSH YPTR Save image function
RCALL ZPTR,INTVAL,,FAIL Get type indicator
POP (YPTR,XPTR) Restore image and object functions
AEQLC XPTR,0,,NONAME Object may not be null
AEQLC ZPTR,1,,UNYOP Check for unary definition
AEQLC ZPTR,2,,BNYOP Check for binary definition
AEQLC ZPTR,0,INTR30 Check for function definition
RCALL XPTR,FINDEX,XPTR Get function descriptor for object
UNBF RCALL YPTR,FINDEX,YPTR E3.6.2
OPPD MOVDIC XPTR,0,YPTR,0 Move procedure descriptor pair
MOVDIC XPTR,DESCR,YPTR,DESCR
BRANCH RETNUL
*_
UNYOP LOCSP XSP,XPTR Get specifier for image
LEQLC XSP,1,UNAF Length must be 1 for operator
SETSP ZSP,PROTSP E3.5.3
SETLC ZSP,0 E3.5.3
APDSP ZSP,XSP E3.5.3
APDSP ZSP,LPRNSP E3.5.3
STREAM TSP,ZSP,UNOPTB,UNAF,UNAF E3.5.3
MOVD XPTR,STYPE STYPE has function descriptor
UNCF LOCSP YSP,YPTR Get specifier for image
LEQLC YSP,1,UNBF Length must be 1 for operator
SETSP ZSP,PROTSP E3.5.3
SETLC ZSP,0 E3.5.3
APDSP ZSP,YSP E3.5.3
APDSP ZSP,LPRNSP E3.5.3
STREAM TSP,ZSP,UNOPTB,UNBF,UNBF E3.5.3
MOVD YPTR,STYPE STYPE has function descriptor
BRANCH OPPD Join to copy descriptors
*_
UNAF RCALL XPTR,FINDEX,XPTR Find definition of image
BRANCH UNCF Join search for object
*_
BNYOP LOCSP XSP,XPTR Get specifier for image
LCOMP XSP,EQLSP,BNAF Length must be 2 or less
SETSP ZSP,PROTSP E3.5.3
SETLC ZSP,0 E3.5.3
APDSP ZSP,XSP E3.5.3
APDSP ZSP,BLSP E3.5.3
STREAM TSP,ZSP,BIOPTB,BNAF,BNAF E3.5.3
LEQLC ZSP,0,BNAF E3.5.3
MOVD XPTR,STYPE STYPE has function descriptor
BNCF LOCSP YSP,YPTR Get specifier for object
LCOMP YSP,EQLSP,BNBF Length must be 2 or less
SETSP ZSP,PROTSP E3.5.3
SETLC ZSP,0 E3.5.3
APDSP ZSP,YSP E3.5.3
APDSP ZSP,BLSP E3.5.3
STREAM TSP,ZSP,BIOPTB,BNBF,BNBF E3.5.3
LEQLC ZSP,0,BNBF E3.5.3
MOVD YPTR,STYPE STYPE has function descriptor
BRANCH OPPD Join to copy descriptors
*_
BNAF LEXCMP XSP,BLSP,,BNCN Check for concatenation
RCALL XPTR,FINDEX,XPTR Find definition of image
BRANCH BNCF Join search for object
*_
BNCN MOVD XPTR,CONCL CONCL represents concatenation
BRANCH BNCF Join search for object
*_
BNBF LEXCMP YSP,BLSP,UNBF,,UNBF Check for concatenation
MOVD YPTR,CONCL CONCL represents concatenation
BRANCH OPPD Join to copy descriptors
*_
*---------------------------------------------------------------------*
*
* REPLACE(S1,S2,S3)
*
RPLACE PROC , REPLACE(S1,S2,S3)
RCALL XPTR,VARVAL,,FAIL Get first argument
PUSH XPTR Save first argument
RCALL YPTR,VARVAL,,FAIL Get second argument
PUSH YPTR Save second argument
RCALL ZPTR,VARVAL,,FAIL Get third argument
POP (YPTR,XPTR) Restore first and second
AEQLC XPTR,0,,RTXPTR Ignore replacement on null
LOCSP YSP,YPTR Get specifier for second
LOCSP ZSP,ZPTR Get specifier for third
LCOMP ZSP,YSP,FAIL,,FAIL Verify same lengths
AEQLC YPTR,0,,FAIL Ignore null replacement
LOCSP XSP,XPTR Get specifier for first
GETLG XCL,XSP Get length
RCALL ZPTR,CONVAR,XCL Allocate space for result
LOCSP TSP,ZPTR Get specifier
SETLC TSP,0 Clear specifier
APDSP TSP,XSP Append first argument
RPLACE TSP,YSP,ZSP Perform replacement
BRANCH GENVSZ Got generate variable
*_
*---------------------------------------------------------------------*
*
* SIZE(S)
*
SIZE PROC , SIZE(S)
RCALL XPTR,VARVAL,,FAIL Get argument
LOCSP XSP,XPTR Get specifier
GETLG ZPTR,XSP Get length
SETVC ZPTR,I Insert INTEGER data type
BRANCH RTZPTR Return length
*_
*---------------------------------------------------------------------*
*
* TIME()
*
TIME PROC , TIME()
RCALL ,ARGVAL,,FAIL Get rid of argument
MSTIME ZPTR Get elapsed time
SUBTRT ZPTR,ZPTR,ETMCL Compute time in interpreter
SETVC ZPTR,I Insert INTEGER data type
BRANCH RTZPTR Return time
*_
*---------------------------------------------------------------------*
*
* TRIM(S)
*
TRIM PROC , TRIM(S)
RCALL XPTR,VARVAL,,FAIL Get string
LOCSP ZSP,XPTR Get specifier
TRIMSP ZSP,ZSP Trim string
BRANCH GENVRZ Generate new variable
*_
*---------------------------------------------------------------------*
TITLE 'Common Code'
DATA LHERE ,
RT1NUL RRTURN NULVCL,1 Return null string by exit 1
*_
RTN1 LHERE ,
FAIL RRTURN ,1 Return by exit 1
*_
RETNUL RRTURN NULVCL,3 Return null string by exit 3
*_
RTN2 RRTURN ,2 Return by exit 2
*_
RTN3 LHERE ,
RTNUL3 RRTURN ,3 Return by exit 3
*_
RTXNAM RRTURN XPTR,2 Return XPTR by exit 2
*_
RTXPTR RRTURN XPTR,3 Return XPTR by exit 3
*_
RTYPTR RRTURN YPTR,3 Return YPTR by exit 3
*_
ARTN INCRA ARTHCL,1 Increment count of arithmetic
RTZPTR RRTURN ZPTR,3 Return ZPTR by exit 3
*_
A5RTN RRTURN A5PTR,1 Return A5PTR by exit 1
*_
TSALF BRANCH SALF,SCNR Branch to SALF in scanner
*_
TSALT BRANCH SALT,SCNR Branch to SALT in scanner
*_
TSCOK BRANCH SCOK,SCNR Branch to SCOK in scanner
*_
GENVSZ RCALL ZPTR,GNVARS,XCL,RTZPTR
* Generate variable from storage
*_
GENVRZ RCALL ZPTR,GENVAR,ZSPPTR,RTZPTR
* Generate variable
*_
GENVIX RCALL XPTR,GNVARI,XPTR,RTXNAM
* Generate variable from integer
*_
TITLE 'Termination'
END OUTPUT OUTPUT,NRMEND,(LVLCL)
* End procedure
OUTPUT OUTPUT,LASTSF,(STNOCL)
* Print status
BRANCH FTLEN2 Join termination procedure
*_
FTLEND OUTPUT OUTPUT,FTLCF,(ERRTYP,STNOCL,LVLCL) V3.7
AEQLC INICOM,0,FTLEN3 BE SURE OF INITIALIZATION E3.10.6
OUTPUT OUTPUT,ALOCFL WARN USER E3.10.6
BRANCH ENDALL GET OUT E3.10.6
*_ E3.10.6
FTLEN3 MULTC YCL,ERRTYP,DESCR E3.10.6
GETD YCL,MSGNO,YCL Get message pointer
GETSPC TSP,YCL,0 Get message specifier
STPRNT IOKEY,OUTBLK,TSP Print error message
FTLEN2 ISTACK , Reset system stack
AEQLC ETMCL,0,FTLEN4 Was compiler done?
MSTIME ETMCL Time out compiler
SUBTRT TIMECL,ETMCL,TIMECL Compute time in compiler
SETAC ETMCL,0 Set interpreter time to 0
BRANCH FTLEN1 Join end game
*_
FTLEN4 MSTIME XCL Time out interpreter
SUBTRT ETMCL,XCL,ETMCL Compute time in interpreter
FTLEN1 AEQLC DMPCL,0,,END1 Check &DUMP
AEQLC NODPCL,0,DMPNO Check storage condition
ORDVST , Order string structures
OUTPUT OUTPUT,STDMP Print dump title
OUTPUT OUTPUT,NVARF Print subtitle
RCALL ,DUMP,,(INTR10,INTR10,DMPK)
* Dump natural variables
*_
DMPNO OUTPUT OUTPUT,INCGCF Print disclaimer
OUTPUT OUTPUT,NODMPF Print reason
BRANCH END1 Join end game
*_
DMPK RCALL ,DMK Dump keywords
END1 OUTPUT OUTPUT,STATHD Print statistics title
OUTPUT OUTPUT,CMTIME,(TIMECL)
* Print compilation time
OUTPUT OUTPUT,INTIME,(ETMCL)
* Print interpretation time
OUTPUT OUTPUT,EXNO,(EXNOCL,FALCL)
* Print execution stats
OUTPUT OUTPUT,ARTHNO,(ARTHCL)
* Print arithmetic stats
OUTPUT OUTPUT,SCANNO,(SCNCL)
* Print scanner stats
OUTPUT OUTPUT,STGENO,(GCNO)
* Print regeneration stats
OUTPUT OUTPUT,READNO,(RSTAT)
* Print read stats
OUTPUT OUTPUT,WRITNO,(WSTAT)
* Print write stats
AEQLC EXNOCL,0,END2 Check for no interpretation
INTRL FCL,ZEROCL
BRANCH AVTIME Join end game
*_
END2 INTL EXNOCL,EXNOCL Convert execution total tn RAL
INTRL XCL,ETMCL Convert execution time to REAL
DVREAL FCL,XCL,EXNOCL Compute average time
AVTIME OUTPUT OUTPUT,TIMEPS,(FCL) Print average time
ENDALL ENDEX ABNDCL E3.2.2
*_
SYSCUT OUTPUT OUTPUT,SYSCMT,(STNOCL,LVLCL)
* System cut exit
AEQLC CUTNO,0,ENDALL E3.2.2
SETAC CUTNO,1 E3.2.2
BRANCH FTLEN2 Join end game
*_
*---------------------------------------------------)-----------------*
TITLE 'Error Handling' "%
AERROR SETAC ERRTYP,2 Arithmetic error
BRANCH FTLTST
*_
ALOC2 SETAC ERRTYP,20 Storage exhausted
BRANCH FTLEND
*_
ARGNER SETAC ERRTYP,25 Incorrect number of arguments
BRANCH FTLEND
*_
INTR10 LHERE ,
INTR13 LHERE ,
COMP3 SETAC ERRTYP,17 Program error
BRANCH FTLEND
*_
COMP5 SETAC ERRTYP,11 Reading error
BRANCH FTLTST
*_
COMP7 SETAC ERRTYP,27 Erroneous end statement
BRANCH FTLEND
*_
COMP9 SETAC ERRTYP,26 Compilation error limit
DECRA ESAICL,DESCR Decrement error count
BRANCH FTLEND
*_
EROR SETAC ERRTYP,28 Erroneous statement
INCRA OCICL,DESCR Increment offset
GETD STNOCL,OCBSCL,OCICL Get statement number
BRANCH FTLEND
*_
EXEX SETAC ERRTYP,22 Exceeded &STLIMIT
BRANCH FTLEND
*_
INTR1 SETAC ERRTYP,1 Illegal data type
BRANCH FTLTST
*_
INTR4 SETAC ERRTYP,24 Erroneous goto
BRANCH FTLEND
*_
INTR5 SETAC ERRTYP,19 Failure in goto
BRANCH FTLEND
*_
INTR8 SETAC ERRTYP,15 Exceeded &MAXLNGTH
BRANCH FTLTST
*_
INTR27 SETAC ERRTYP,13 Excessive data types
BRANCH FTLTST
*_
INTR30 SETAC ERRTYP,10 Illegal argument
BRANCH FTLTST
*_
INTR31 SETAC ERRTYP,16 Overflow in pattern matching
SETAC SCERCL,3
BRANCH FTERST
*_
LENERR SETAC ERRTYP,14 Negative number
BRANCH FTLTST
*_
MAIN1 SETAC ERRTYP,18 Return from level zero
BRANCH FTLEND
*_
NEMO SETAC ERRTYP,8 Variable not present
BRANCH FTLTST
*_
NONAME SETAC ERRTYP,4 Null string
BRANCH FTLTST
*_
NONARY SETAC ERRTYP,3 Erroneous array or table reference
BRANCH FTLTST
*_
OVER SETAC ERRTYP,21 Stack overflow
BRANCH FTLEND
*_
PROTER SETAC ERRTYP,6 Erroneous prototype
BRANCH FTLTST
*_
SCDTER SETAC ERRTYP,1 Illegal data type
BRANCH SCERST
*_
SCLENR SETAC ERRTYP,14 Negative number
BRANCH SCERST
*_
SCLNOR SETAC ERRTYP,15 String overflow
BRANCH SCERST
*_
SCNAME SETAC ERRTYP,4 Null string
BRANCH SCERST
*_
SCNEMO SETAC ERRTYP,8 E3.4.4
BRANCH SCERST E3.4.4
*_ E3.4.4
SIZERR SETAC ERRTYP,23 Object too large
BRANCH FTLEND
*_
UNDF SETAC ERRTYP,5 Undefined function
BRANCH FTLTST
*_
UNDFFE SETAC ERRTYP,9 Function entry point not label
BRANCH FTLTST
*_
UNKNKW SETAC ERRTYP,7 Unknown keyword
BRANCH FTLTST
*_
UNTERR SETAC ERRTYP,12 Illegal I/O unit
BRANCH FTLTST
*_
SCERST SETAC SCERCL,1 Note failure during pattern matching
BRANCH FTERST
*_
FTLTST SETAC SCERCL,2 Note failure out of pattern matching
FTERST ACOMPC ERRLCL,0,,FTLEND,FTLEND
* Check &ERRLIMIT
DECRA ERRLCL,1 Decrement &ERRLIMIT
ACOMPC TRAPCL,0,,FTERBR,FTERBR
* Check &TRACE
LOCAPT ATPTR,TKEYL,ERRTKY,FTERBR
* Look for KEYWORD trace
PUSH SCERCL E3.1.3
RCALL ,TRPHND,ATPTR E3.3.1
* Perform trace
POP SCERCL E3.1.3
FTERBR SELBRA SCERCL,(TSALF,FAIL,RTNUL3)
*_
*---------------------------------------------------------------------*
TITLE 'Data'
DTLIST DESCR DTLIST,TTL+MARK,DTLEND-DTLIST-DESCR
DESCR 0,0,S
DESCR VARSP,0,0 STRING
DESCR 0,0,I
DESCR INTGSP,0,0 INTEGER
DESCR 0,0,P
DESCR PATSP,0,0 PATTERN
DESCR 0,0,A
DESCR ARRSP,0,0 ARRAY
DESCR 0,0,R
DESCR RLSP,0,0 REAL
DESCR 0,0,C
DESCR CODESP,0,0 CODE
DESCR 0,0,N
DESCR NAMESP,0,0 NAME
DESCR 0,0,K
DESCR NAMESP,0,0 NAME (for keyword)
DESCR 0,0,E
DESCR EXPSP,0,0 EXPRESSION
DESCR 0,0,T
DESCR ASSCSP,0,0 TABLE
DTLEND LHERE ,
*
KNLIST DESCR KNLIST,TTL+MARK,KNEND-KNLIST-DESCR
TRIMCL DESCR 0,0,I &TRIM
DESCR TRMSP,0,0
TRAPCL DESCR 0,0,I &TRACE
DESCR TRCESP,0,0
EXLMCL DESCR 50000,0,I &STLIMIT
DESCR STLMSP,0,0
OUTSW DESCR 1,0,I &OUTPUT
DESCR OUTSP,0,0
MLENCL DESCR 5000,0,I &MAXLNGTH
DESCR MAXLSP,0,0
INSW DESCR 1,0,I &INPUT
DESCR INSP,0,0
FULLCL DESCR 0,0,I &FULLSCAN
DESCR FULLSP,0,0
TRACL DESCR 0,0,I &FTRACE
DESCR FTRCSP,0,0
ERRLCL DESCR 0,0,I &ERRLIMIT
DESCR ERRLSP,0,0
DMPCL DESCR 0,0,I &DUMP
DESCR DUMPSP,0,0
RETCOD DESCR 0,0,I &CODE
DESCR CODESP,0,0
ANCCL DESCR 0,0,I &ANCHOR
DESCR ANCHSP,0,0
ABNDCL DESCR 0,0,I &ABEND
DESCR ABNDSP,0,0
KNEND LHERE ,
*
KVLIST DESCR KVLIST,TTL+MARK,KVEND-KVLIST-DESCR
ERRTYP DESCR 0,0,I &ERRTYPE
ERRTKY DESCR ERRTSP,0,0
ARBPAT DESCR ARBPT,0,P &ARB
ARBKY DESCR ARBSP,0,0
BALPAT DESCR BALPT,0,P &BAL
BALKY DESCR BALSP,0,0
FNCPAT DESCR FNCEPT,0,P &FENCE
FNCEKY DESCR FNCESP,0,0
ABOPAT DESCR ABORPT,0,P &ABORT
ABRTKY DESCR ABORSP,0,0
FALPAT DESCR FAILPT,0,P &FAIL
FAILKY DESCR FAILSP,0,0
REMPAT DESCR REMPT,0,P &REM
REMKY DESCR REMSP,0,0
SUCPAT DESCR SUCCPT,0,P &SUCCEED
SUCCKY DESCR SUCCSP,0,0
FALCL DESCR 0,0,I &STFCOUNT
FALKY DESCR STFCSP,0,0
LSTNCL DESCR 0,0,I &LASTNO
DESCR LSTNSP,0,0
RETPCL DESCR 0,0,S &RTNTYPE
DESCR RTYPSP,0,0
STNOCL DESCR 0,0,I &STNO
DESCR STNOSP,0,0
ALPHVL DESCR 0,0,0 &ALPHABET
DESCR ALNMSP,0,0
EXNOCL DESCR 0,0,I &STCOUNT
STCTKY DESCR STCTSP,0,0
LVLCL DESCR 0,0,I &FNCLEVEL
FNCLKY DESCR FNCLSP,0,0
KVEND LHERE ,
*
INLIST DESCR INLIST,TTL+MARK,2*DESCR
DESCR INPUT-DESCR,0,0 INPUT block
DESCR INSP,0,0
OTLIST DESCR OTLIST,TTL+MARK,4*DESCR
DESCR OUTPUT-DESCR,0,0 OUTPUT block
DESCR OUTSP,0,0
DESCR PUNCH-DESCR,0,0 PUNCH block
DESCR PNCHSP,0,0
OTSATL DESCR OTSATL,TTL+MARK,4*DESCR
OUTPUT DESCR UNITO,0,I OUTPUT unit
DESCR OUTPSP,0,0 OUTPUT format
PUNCH DESCR UNITP,0,I PUNCH unit
PCHFST DESCR CRDFSP,0,0 PUNCH format
INSATL DESCR INSATL,TTL+MARK,2*DESCR
INPUT DESCR UNITI,0,I INPUT unit
DFLSIZ DESCR 80,0,I INPUT length
*
TRLIST DESCR TRLIST,TTL+MARK,10*DESCR
DESCR TVALL,0,0 VALUE trace
VALTRS DESCR VALSP,0,0
DESCR TLABL,0,0 LABEL trace
DESCR TRLASP,0,0
TFNCLP DESCR TFENTL,0,0 CALL trace
DESCR TRFRSP,0,0
TFNRLP DESCR TFEXTL,0,0 RETURN trace
DESCR RETSP,0,0
DESCR TKEYL,0,0 KEYWORD trace
DESCR TRKYSP,0,0
*
TRCBLK DESCR TRCBLK,TTL+MARK,5*DESCR V3.7
DESCR 0,FNC,2 TRACE FUNCTION DESCRIPTOR V3.7
LIT1CL DESCR LITFN,FNC,1 LITERAL FUNCTION DESCRIPTOR E3.7.1
DESCR 0,0,0 VARIABLE TO BE TRACED V3.7
DESCR LITFN,FNC,1 LITERAL FUNCTION DESCRIPTOR E3.7.1
DESCR 0,0,0 TAG SUPPLIED FOR TRACE V3.7
*
ATRHD DESCR ATPRCL-DESCR,0,0 Array header converting from TABLE
ATPRCL DESCR 0,0,0 Prototype
DESCR 2,0,0 Dimensionality
DESCR 1,0,2 1:2 second dimension
ATEXCL DESCR 1,0,0 1:n first dimension
*
* Data type pairs
*
ATDTP DESCR A,0,T ARRAY-TABLE
IIDTP DESCR I,0,I INTEGER-INTEGER
IPDTP DESCR I,0,P INTEGER-PATTERN
IRDTP DESCR I,0,R INTEGER-REAL
IVDTP DESCR I,0,S INTEGER-STRING
PIDTP DESCR P,0,I PATTERN-INTEGER
PPDTP DESCR P,0,P PATTERN-PATTERN
PVDTP DESCR P,0,S PATTERN-STRING
RIDTP DESCR R,0,I REAL-INTEGER
RPDTP DESCR R,0,P REAL-PATTERN
RRDTP DESCR R,0,R REAL-REAL
RVDTP DESCR R,0,S REAL-STRING
TADTP DESCR T,0,A TABLE-ARRAY
VCDTP DESCR S,0,C STRING-CODE
VEDTP DESCR S,0,E STRING-EXPRESSION
VIDTP DESCR S,0,I STRING-INTEGER
VPDTP DESCR S,0,P STRING-PATTERN
VRDTP DESCR S,0,R STRING-REAL
VVDTP DESCR S,0,S STRING-STRING
*
ARTHCL DESCR 0,0,0 Number of arithmetic operations
CSTNCL DESCR 0,0,I Compiler statement number
RSTAT DESCR 0,0,0 Number of reads
SCNCL DESCR 0,0,0 Number of scanner entrances
WSTAT DESCR 0,0,0 Number of writes
TIMECL DESCR 0,0,0 Millisecond time
*
* SWITCHES
*
ALCL DESCR 0,0,0 Entry point switch for ARG(F,N)
ARRMRK DESCR 0,0,0 Prototype end switch for ARRAY(P,V)
CUTNO DESCR 0,0,0 E3.2.2
CNSLCL DESCR 0,0,0 Label redefinition switch
DATACL DESCR 0,0,0 Prototype end switch for DATA(P)
FNVLCL DESCR 0,0,0 FUNCTION-VALUE switch for trace
INICOM DESCR 0,0,0 INITIALIZATION SWITCH E3.10.6
LENFCL DESCR 0,0,0 Length failure switch
LISTCL DESCR 1,0,0 Compiler listing switch
LLIST DESCR 0,0,0 Left listing switch
NAMGCL DESCR 0,0,0 Naming switch for SJSR
SCERCL DESCR 0,0,0 Error branch switch
*
* Constants
*
ARBSIZ DESCR 8*NODESZ,0,0 Node size for ARBNO(P)
CHARCL DESCR 1,0,0 Length constant 1
CNDSIZ DESCR CNODSZ,0,B Compiler node size
CODELT DESCR 200*DESCR,0,C Object code excess
DSCRTW DESCR 2*DESCR,0,0 Constant 2*DESCR
EOSCL DESCR EOSTYP,0,0 End of statement switch
ESALIM DESCR ESASIZ*DESCR,0,0 Bound on compilation errors
EXTVAL DESCR EXTSIZ*2*DESCR,0,0 V3.11
FBLKRQ DESCR FBLKSZ,0,B Quantum on allocated function blocks
GOBRCL DESCR 0,0,0 Goto break character switch
GTOCL DESCR FGOTYP,0,0 Goto decision switch
IOBLSZ DESCR 2*DESCR,0,B Size of I/O blocks
LNODSZ DESCR NODESZ+DESCR,0,P Size of long pattern node
NODSIZ DESCR NODESZ,0,P Size of short pattern node
OBEND DESCR OBLIST+DESCR*OBOFF,0,0
* End on bin list
OCALIM DESCR OCASIZ*DESCR,0,C Size of object code block
ONECL DESCR 1,0,0 Constant 1
OUTBLK DESCR OUTPUT-DESCR,0,0 Pointer to OUTPUT block
SIZLMT DESCR SIZLIM,0,0 Limit on size of data object
SNODSZ DESCR NODESZ,0,P Small pattern node size
STARSZ DESCR 11*DESCR,0,P Size of EXPRESSION pattern
ZEROCL DESCR 0,0,0 Constant zero
TRSKEL DESCR TRCBLK,0,0
COMDCT DESCR 14*DESCR,0,0
COMREG DESCR ELEMND,0,0 Pointer to compiler descriptors
*
*
*
* Pointers to Assembled Data Patterns
*
ARBACK DESCR ARBAK,0,P
ARHEAD DESCR ARHED,0,P
ARTAIL DESCR ARTAL,0,P
STRPAT DESCR STARPT,0,P
*
* Function Descriptors
*
ANYCCL DESCR ANYCFN,FNC,3
ASGNCL DESCR ASGNFN,FNC,2
ATOPCL DESCR ATOPFN,FNC,3
BASECL DESCR BASEFN,FNC,0
BRKCCL DESCR BRKCFN,FNC,3
CHRCL DESCR CHRFN,FNC,3
CONCL DESCR CONFN,FNC,0 Argument count is incremented
DNMECL DESCR DNMEFN,FNC,2
DNMICL DESCR DNMIFN,FNC,2
ENDCL DESCR ENDFN,FNC,0
ENMECL DESCR ENMEFN,FNC,3
ENMICL DESCR ENMIFN,FNC,3
ERORCL DESCR ERORFN,FNC,1
FNCFCL DESCR FNCFFN,FNC,2
FNMECL DESCR FNMEFN,FNC,2
GOTGCL DESCR GOTGFN,FNC,1
GOTLCL DESCR GOTLFN,FNC,1
GOTOCL DESCR GOTOFN,FNC,1
INITCL DESCR INITFN,FNC,1
ITEMCL DESCR AREFN,FNC,0
LITCL DESCR LITFN,FNC,0 Argument count is incremented
LNTHCL DESCR LNTHFN,FNC,3
NMECL DESCR NMEFN,FNC,2
NNYCCL DESCR NNYCFN,FNC,3
POSICL DESCR POSIFN,FNC,3
RPSICL DESCR RPSIFN,FNC,3
RTBCL DESCR RTBFN,FNC,3
SCANCL DESCR SCANFN,FNC,2
SCFLCL DESCR SCFLFN,FNC,2
SCOKCL DESCR SCOKFN,FNC,2
SCONCL DESCR SCONFN,FNC,2
SJSRCL DESCR SJSRFN,FNC,3
SPNCCL DESCR SPNCFN,FNC,3
SUCFCL DESCR SUCFFN,FNC,2
TBCL DESCR TBFN,FNC,3
INITB DESCR ABNDB,0,0
INITE DESCR DTEND+DESCR,0,0
*
* Miscellaneous Data Cells
*
A4PTR DESCR 0,0,0 Scratch descriptor
A5PTR DESCR 0,0,0 Scratch descriptor
A6PTR DESCR 0,0,0 Scratch descriptor
A7PTR DESCR 0,0,0 Scratch descriptor
BRTYPE DESCR 0,0,0 Break type returned by FORWRD
CMOFCL DESCR 0,0,0 Compiler offset
DATSEG DESCR 0,0,100 Beginning of defined data types
DMPPTR DESCR 0,0,0 Bin pointer for DUMP
DTCL DESCR 0,0,0 Data type descriptor
DT1CL DESCR 0,0,0 Data type descriptor
EMSGCL DESCR 0,0,0 Present error message address
ERRBAS DESCR CARDSZ+STNOSZ-SEQSIZ,0,0
ESAICL DESCR 0,0,0 Count of compiler errors
ETMCL DESCR 0,0,0 Time descriptor
FCL DESCR 0,0,0 Real number descriptor
NEXFCL DESCR FBLKSZ,0,0 Offset in function block
FRTNCL DESCR 0,0,0 Failure return
GOGOCL DESCR 0,0,0 goto descriptor
INCL DESCR 0,0,0 Global function descriptor
IOKEY DESCR 0,0,0 I/O indicator
MAXLEN DESCR 0,0,0 Maximum length for matching
MSGNO DESCR MSGLST,0,0 Pointer to error message list
NAMICL DESCR 0,0,0 Offset on naming list
NHEDCL DESCR 0,0,0 Name list head offset
NMOVER DESCR NAMLSZ*SPDR,0,B Name list end offset
NULVCL DESCR 0,0,S Null string value
OCICL DESCR 0,0,0 Object code offset
PATICL DESCR 0,0,0 Pattern code offset
PDLEND DESCR PDLBLK+SPDLDR-NODESZ,0,0
* Pattern history list end
PDLPTR DESCR PDLBLK,0,0 Pattern history list beginning
SCL DESCR 0,0,0 Switch descriptor
STKPTR DESCR STACK,0,0 Pointer to stack
STYPE DESCR 0,FNC,0 Descriptor return by STREAM
TBLFNC DESCR 0,0,0 Pointer to last pattern table
UNIT DESCR 0,0,0 Input unit switch
VARSYM DESCR 0,0,0
*
* Program Pointers
*
DATCL DESCR DEFDAT,FNC,0 Defined data objects
DEFCL DESCR DEFFNC,FNC,0 Defined functions
FLDCL DESCR FIELD,0,1 Field of defined data objects
LODCL DESCR LNKFNC,FNC,0 External functions
PDLHED DESCR PDLBLK,0,0 History list head
UNDFCL DESCR UNDF,FNC,0 Undefined functions
*
* Pointers to Specifiers
*
DPSPTR DESCR DPSP,0,0
XSPPTR DESCR XSP,0,0
YSPPTR DESCR YSP,0,0
ZSPPTR DESCR ZSP,0,0
TSPPTR DESCR TSP,0,0
*
* Permanent Attribute List Pointers
*
KNATL DESCR KNLIST,0,0 Unprotected keyword list
KVATL DESCR KVLIST,0,0 Protected keyword list
TRATL DESCR TRLIST,0,0 Trace list
*
* Specifiers for Compilation Listing
*
BLNSP SPEC BLNBUF,0,0,0,STNOSZ
ERRSP SPEC ERRBUF,0,0,0,CARDSZ+STNOSZ-SEQSIZ+1
INBFSP SPEC INBUF,0,0,STNOSZ,CARDSZ
LNBFSP SPEC INBUF,0,0,0,CARDSZ+DSTSZ+1
NEXTSP SPEC INBUF,0,0,STNOSZ,CARDSZ-SEQSIZ
LNOSP SPEC INBUF,0,0,0,STNOSZ
RNOSP SPEC INBUF,0,0,CARDSZ+STNOSZ+1,STNOSZ
*
* Strings and Specifiers
*
ALPHSP SPEC ALPHA,0,0,0,ALPHSZ Alphabet
AMPSP SPEC AMPST,0,0,0,1 Ampersand
CERRSP SPEC ANYSP,0,0,0,0 Buffer specifier
COLSP SPEC COLSTR,0,0,0,2 Colon for trace messages
DMPSP SPEC ANYSP,0,0,0,0 Buffer specifier
DTARSP SPEC DTARBF,0,0,0,ARRLEN+9
* Array representation specifier
PROTSP SPEC ANYSP,0,0,0,0 Buffer specifier
QTSP SPEC QTSTR,0,0,0,1 Quote for messages
REALSP SPEC REALBF,0,0,0,10 Specifier for real conversion
TRACSP SPEC ANYSP,0,0,0,0 Buffer specifier
*
ARRSP STRING 'ARRAY'
ASSCSP STRING 'TABLE'
BLSP STRING ' '
BLEQSP STRING ' = '
CMASP STRING ','
EJCTSP STRING 'EJECT'
EQLSP STRING '= '
ETIMSP STRING ',TIME = '
EXDTSP STRING 'EXTERNAL'
LEFTSP STRING 'LEFT'
LISTSP STRING 'LIST'
LPRNSP STRING '('
OFSP STRING ' OF '
RPRNSP STRING ')'
STARSP STRING '*** '
TRCLSP STRING ' CALL OF '
TRLVSP STRING 'LEVEL '
TRSTSP STRING ' STATEMENT '
UNLSP STRING 'UNLIST'
XFERSP STRING 'TRANSFER TO'
*
* Character Buffers
*
BLNBUF BUFFER STNOSZ Blanks for statment number field
DTARBF BUFFER ARRLEN+7 Array representation buffer
ERRBUF BUFFER CARDSZ+STNOSZ-SEQSIZ+1
INBUF BUFFER CARDSZ+DSTSZ+1 Card input buffer
REALBF BUFFER 36 Buffer for real number conversion
ICLBLK DESCR ICLBLK,TTL+MARK,ICLEND-ICLBLK-DESCR
*
* Pointers to Attribute Lists
*
DTATL DESCR DTLIST,0,0 Data type pair list
FNCPL DESCR FNLIST,0,0 Function pair list
INATL DESCR INLIST,0,0 Input association pair list
OUTATL DESCR OTLIST,0,0 Output association pair list
TVALL DESCR TVALPL,0,0 Value trace pair list
DESCR VLTRFN,FNC,2 Default value trace procedure
TLABL DESCR TLABPL,0,0 Label trace pair list
DESCR LABTFN,FNC,1 Default label trace procedure
TFENTL DESCR TFENPL,0,0 Call trace pair list
DESCR FNTRFN,FNC,2 Default call trace procedure
TFEXTL DESCR TFEXPL,0,0 Return trace pair list
DESCR FXTRFN,FNC,2 Default return trace procedure
TKEYL DESCR TKEYPL,0,0 Keyword trace pair list
DESCR KEYTFN,FNC,1 Default keyword trace procedure
*
* Scratch Descriptors
*
A1PTR DESCR 0,0,0
A2PTR DESCR 0,0,0
A3PTR DESCR 0,0,0
ATPTR DESCR 0,0,0
F1PTR DESCR 0,0,0
F2PTR DESCR 0,0,0
IO2PTR DESCR 0,0,0
IO1PTR DESCR 0,0,0
LPTR DESCR 0,0,0 Last label pointer
NVAL DESCR 0,0,0
IO3PTR DESCR 0,0,0
IO4PTR DESCR 0,0,0
TBLCS DESCR 0,0,0
TMVAL DESCR 0,0,0
TPTR DESCR 0,0,0
TCL DESCR 0,0,0
TSIZ DESCR 0,0,0
TVAL DESCR 0,0,0
VVAL DESCR 0,0,0
WCL DESCR 0,0,0
WPTR DESCR 0,0,0
XCL DESCR 0,0,0
XPTR DESCR 0,0,0
XSIZ DESCR 0,0,0
YCL DESCR 0,0,0
YPTR DESCR 0,0,0
YSIZ DESCR 0,0,0
ZCL DESCR 0,0,0
ZPTR DESCR 0,0,0
ZSIZ DESCR 0,0,0
*
* System Descriptors
*
BOSCL DESCR 0,0,0 Offset of beginning of statement
CMBSCL DESCR 0,0,0 Compiler code base descriptor
NBSPTR DESCR 0,0,0 Name list base pointer
FBLOCK DESCR 0,0,0 Function procedure descriptor block
OCBSCL DESCR 0,0,0 Interpreter code base descriptor
OCLIM DESCR 0,0,0 End of object code block
OCSVCL DESCR 0,0,0 Pointer to basic object code
PATBCL DESCR 0,0,0 Pattern code base descriptor
SCBSCL DESCR 0,0,0
SRNCL DESCR 0,0,0 Success return descriptor
*
* Compiler Descriptors
*
ELEMND DESCR 0,0,0 Element node
ELEXND DESCR 0,0,0 Temporary node
ELEYND DESCR 0,0,0 Temporary node
EXELND DESCR 0,0,0 Temporary node
EXEXND DESCR 0,0,0 Temporary node
EXOPCL DESCR 0,0,0 Operator node
EXOPND DESCR 0,0,0 Operator node
EXPRND DESCR 0,0,0 Expression node
FGOND DESCR 0,0,0 Failure goto node
FORMND DESCR 0,0,0 Object node
FRNCL DESCR 0,0,0 Failure return descriptor
GOTOND DESCR 0,0,0 Goto node
PATND DESCR 0,0,0 Pattern node
SGOND DESCR 0,0,0 Success goto node
SUBJND DESCR 0,0,0 Subject node
*
* Data Pointers
*
DFLFST DESCR 0,0,0 Default output format
ENDPTR DESCR 0,0,0 'END'
EXTPTR DESCR 0,0,0 'EXTERNAL'
FRETCL DESCR 0,0,0 'FRETURN'
NRETCL DESCR 0,0,0 'NRETURN'
RETCL DESCR 0,0,0 'RETURN'
FUNTCL DESCR 0,0,0 'FUNCTION'
*
* Specifiers
*
DPSP SPEC 0,0,0,0,0 Data type specifier
HEADSP SPEC 0,0,0,0,0 Matching head specifier
IOSP SPEC 0,0,0,0,0 I/O specifier
TAILSP SPEC 0,0,0,0,0 Matching tail specifier
TEXTSP SPEC 0,0,0,0,0 Compiler statement specifier
TSP SPEC 0,0,0,0,0 Scratch specifier
TXSP SPEC 0,0,0,0,0 Scratch specifier
VSP SPEC 0,0,0,0,0 Scratch specifier
XSP SPEC 0,0,0,0,0 Scratch specifier
YSP SPEC 0,0,0,0,0 Scratch specifier
ZSP SPEC 0,0,0,0,0 Scratch specifier
*
* Allocator Data
*
ARG1CL DESCR 0,0,0 Scratch descriptor
BUKPTR DESCR 0,PTR,S Bin pointer
LSTPTR DESCR 0,PTR,S Pointer to last structure
AXPTR DESCR 0,0,0 Allocation size descriptor
SPECR1 SPEC 0,0,0,0,0 Scratch specifier
SPECR2 SPEC 0,0,0,0,0 Scratch specifier
ICLEND LHERE , End of basic block
*
* Allocator Data
*
BK1CL DESCR 0,0,0 Pointer to block being marked
BKDX DESCR 0,0,0 Offset in block being marked
BKDXU DESCR 0,0,0 Offset in block
BKLTCL DESCR 0,0,0
BKPTR DESCR 0,PTR,S
BLOCL DESCR 0,0,0
CONVSW DESCR 0,0,0 CONVAR-GENVAR entry switch
CPYCL DESCR 0,0,0 Regeneration block pointer
DESCL DESCR 0,0,0 Regeneration scratch descriptor
EQUVCL DESCR 0,0,0 Variable identification descriptor
FRDSCL DESCR 4*DESCR,0,0
GCBLK DESCR GCXTTL,0,0 Pointer to marking block
GCNO DESCR 0,0,0 Count of regenerations
GCMPTR DESCR 0,0,0 Pointer to basic blocks
GCREQ DESCR 0,0,0 Space required from regeneration
GCGOT DESCR 0,0,I Space obtained from regeneration
LCPTR DESCR 0,0,0 Scratch descriptor
MVSGPT DESCR 0,0,0 Compression boundary pointer
NODPCL DESCR 0,0,0 Regeneration switch
OBPTR DESCR OBLIST,PTR,S Pointer to bins
OFSET DESCR 0,0,0 Offset in block during regeneration
PRMDX DESCR PRMSIZ,0,0 Size of basic block list
PRMPTR DESCR PRMTBL,0,0 Pointer to list of basic blocks
ST1PTR DESCR 0,PTR,S Regeneration link pointer
ST2PTR DESCR 0,PTR,S Regeneration link pointer
TEMPCL DESCR 0,PTR,0 Scracth descriptor
TOPCL DESCR 0,0,0 Pointer to block title
TTLCL DESCR 0,0,0 Pointer to block title
TWOCL DESCR 2*DESCR,0,B Size of string to be marked
*
*
FRSGPT DESCR 0,PTR,0 Position pointer
HDSGPT DESCR 0,PTR,0 Head of allocated data region
TLSGP1 DESCR 0,PTR,0 End of allocated data region
GCXTTL DESCR GCXTTL,TTL+MARK,DESCR
* Block to prime marking procedure
DESCR 0,0,0 Pointer to block to mark
*
* Machine-dependent Data
*
COPY MDATA Segment of machine-dependent data
*
* Function Table
*
FTABLE DESCR FTABLE,TTL+MARK,FTBLND-FTABLE-DESCR
*
* Primitive Functions
*
ANYFN DESCR ANY,0,1
DESCR 0,0,0
APLYFN DESCR APPLY,FNC,1
DESCR 0,0,0
ARBOFN DESCR ARBNO,0,1
DESCR 0,0,0
ARGFN DESCR ARG,0,2
DESCR 0,0,0
ARRAFN DESCR ARRAY,0,2
DESCR 0,0,0
ASSCFN DESCR ASSOC,0,2
DESCR 0,0,0
BACKFN DESCR BKSPCE,0,1
DESCR 0,0,0
BREAFN DESCR BREAK,0,1
DESCR 0,0,0
CLEAFN DESCR CLEAR,0,1
DESCR 0,0,0
CODEFN DESCR CODER,0,1
DESCR 0,0,0
COLEFN DESCR COLECT,0,1
DESCR 0,0,0
CNVRFN DESCR CNVRT,0,2
DESCR 0,0,0
COPYFN DESCR COPY,0,1
DESCR 0,0,0
DATFN DESCR DATE,0,1
DESCR 0,0,0
DATDFN DESCR DATDEF,0,1
DESCR 0,0,0
DEFIFN DESCR DEFINE,0,2
DESCR 0,0,0
DIFFFN DESCR DIFFER,0,2
DESCR 0,0,0
DTCHFN DESCR DETACH,0,1
DESCR 0,0,0
DTFN DESCR DT,0,1
DESCR 0,0,0
DUMPFN DESCR DMP,0,1
DESCR 0,0,0
DUPLFN DESCR DUPL,0,2
DESCR 0,0,0
ENDFFN DESCR ENFILE,0,1
DESCR 0,0,0
EQFN DESCR EQ,0,2
DESCR 0,0,0
EVALFN DESCR EVAL,0,1
DESCR 0,0,0
FLDSFN DESCR FIELDS,0,2
DESCR 0,0,0
GEFN DESCR GE,0,2
DESCR 0,0,0
GTFN DESCR GT,0,2
DESCR 0,0,0
IDENFN DESCR IDENT,0,2
DESCR 0,0,0
INTGFN DESCR INTGER,0,1
DESCR 0,0,0
ITEMFN DESCR ITEM,FNC,1
DESCR 0,0,0
LEFN DESCR LE,0,2
DESCR 0,0,0
LENFN DESCR LEN,0,1
DESCR 0,0,0
LGTFN DESCR LGT,0,2
DESCR 0,0,0
LOADFN DESCR LOAD,0,2
DESCR 0,0,0
LOCFN DESCR LOCAL,0,2
DESCR 0,0,0
LTFN DESCR LT,0,2
DESCR 0,0,0
NEFN DESCR NE,0,2
DESCR 0,0,0
NOTAFN DESCR NOTANY,0,1
DESCR 0,0,0
OPSYFN DESCR OPSYN,0,3
DESCR 0,0,0
POSFN DESCR POS,0,1
DESCR 0,0,0
PRINFN DESCR PRINT,0,3
DESCR 0,0,0
PROTFN DESCR PROTO,0,1
DESCR 0,0,0
REMDFN DESCR REMDR,0,2
DESCR 0,0,0
RPLAFN DESCR RPLACE,0,3
DESCR 0,0,0
READFN DESCR READ,0,3
DESCR 0,0,0
REWNFN DESCR REWIND,0,1
DESCR 0,0,0
RPOSFN DESCR RPOS,0,1
DESCR 0,0,0
RTABFN DESCR RTAB,0,1
DESCR 0,0,0
SIZEFN DESCR SIZE,0,1
DESCR 0,0,0
SPANFN DESCR SPAN,0,1
DESCR 0,0,0
STPTFN DESCR STOPTR,0,2
DESCR 0,0,0
TABFN DESCR TAB,0,1
DESCR 0,0,0
TIMFN DESCR TIME,0,1
DESCR 0,0,0
TRCEFN DESCR TRACE,0,4
DESCR 0,0,0
TRIMFN DESCR TRIM,0,1
DESCR 0,0,0
UNLDFN DESCR UNLOAD,0,1
DESCR 0,0,0
VALFN DESCR FIELD,0,1
DESCR VALBLK,0,0
FTBLND LHERE ,
*
INITLS DESCR INITLS,TTL+MARK,8*DESCR
DESCR DTLIST,0,0
DESCR FNLIST,0,0
DESCR INLIST,0,0
DESCR KNLIST,0,0
DESCR KVLIST,0,0
DESCR OTLIST,0,0
DESCR OTSATL,0,0
DESCR TRLIST,0,0
*
* Function Pair List
*
FNLIST DESCR FNLIST,TTL+MARK,FNCPLE-FNLIST-DESCR
DESCR ANYFN,FNC,0 ANY(CS)
DESCR ANYSP,0,0
DESCR APLYFN,FNC,0 APPLY(F,A1,...,AN)
DESCR APLYSP,0,0
DESCR ARBOFN,FNC,0 ARBNO(P)
DESCR ARBNSP,0,0
DESCR ARGFN,FNC,0 ARG(F,N)
DESCR ARGSP,0,0
DESCR ARRAFN,FNC,0 ARRAY(P,V)
DESCR ARRSP,0,0
DESCR BACKFN,FNC,0 BACKSPACE(N)
DESCR BACKSP,0,0
DESCR BREAFN,FNC,0 BREAK(CS)
DESCR BRKSP,0,0
DESCR CLEAFN,FNC,0 CLEAR()
DESCR CLERSP,0,0
DESCR CODEFN,FNC,0 CODE(S)
DESCR CODESP,0,0
DESCR COLEFN,FNC,0 COLLECT(N)
DESCR CLSP,0,0
DESCR CNVRFN,FNC,0 CONVERT(V,DT)
DESCR CNVTSP,0,0
DESCR COPYFN,FNC,0 COPY(V)
DESCR COPYSP,0,0
DESCR DATDFN,FNC,0 DATA(P)
DESCR DATASP,0,0
DESCR DATFN,FNC,0 E3.0.5
DESCR DATSP,0,0
DESCR DEFIFN,FNC,0 DEFINE(P,L)
DESCR DEFISP,0,0
DESCR DIFFFN,FNC,0 DIFFER(V1,V2)
DESCR DIFFSP,0,0
DESCR DTCHFN,FNC,0 DETACH(V)
DESCR DTCHSP,0,0
DESCR DTFN,FNC,0 DATATYPE(V)
DESCR DTSP,0,0
DESCR DUMPFN,FNC,0 DUMP()
DESCR DUMPSP,0,0
DESCR DUPLFN,FNC,0 DUPL(S,N)
DESCR DUPLSP,0,0
DESCR ENDFFN,FNC,0 ENDFILE(N)
DESCR ENDFSP,0,0
DESCR EQFN,FNC,0 EQ(I1,I2)
DESCR EQSP,0,0
DESCR EVALFN,FNC,0 EVAL(E)
DESCR EVALSP,0,0
DESCR FLDSFN,FNC,0 FIELD(V,N)
DESCR FLDSSP,0,0
DESCR GEFN,FNC,0 GE(I1,I2)
DESCR GESP,0,0
DESCR GTFN,FNC,0 GT(I1,I2)
DESCR GTSP,0,0
DESCR IDENFN,FNC,0 IDENT(V1,V2)
DESCR IDENSP,0,0
DESCR READFN,FNC,0 INPUT(V,N,L)
DESCR INSP,0,0
DESCR INTGFN,FNC,0 INTEGER(V)
DESCR INTGSP,0,0
DESCR ITEMFN,FNC,0 ITEM(A,I1,...,IN)
DESCR ITEMSP,0,0
DESCR LENFN,FNC,0 LEN(N)
DESCR LENSP,0,0
DESCR LEFN,FNC,0 LE(I1,I2)
DESCR LESP,0,0
DESCR LGTFN,FNC,0 LGT(S1,S2)
DESCR LGTSP,0,0
DESCR LOADFN,FNC,0 LOAD(P)
DESCR LOADSP,0,0
DESCR LOCFN,FNC,0 LOCAL(F,N)
DESCR LOCSP,0,0
DESCR LTFN,FNC,0 LT(I1,I2)
DESCR LTSP,0,0
DESCR NEFN,FNC,0 NE(I1,I2)
DESCR NESP,0,0
DESCR NOTAFN,FNC,0 NOTANY(CS)
DESCR NNYSP,0,0
DESCR OPSYFN,FNC,0 OPSYN(F1,F2,N)
DESCR OPSNSP,0,0
DESCR PRINFN,FNC,0 OUTPUT(V,N,F)
DESCR OUTSP,0,0
DESCR POSFN,FNC,0 POS(N)
DESCR POSSP,0,0
DESCR PROTFN,FNC,0 PROTOTYPE(A)
DESCR PRTSP,0,0
DESCR REMDFN,FNC,0 REMDR(N,M)
DESCR REMDSP,0,0
DESCR REWNFN,FNC,0 REWIND(N)
DESCR REWNSP,0,0
DESCR RPLAFN,FNC,0 REPLACE(S,CS1,CS2)
DESCR RPLCSP,0,0
DESCR RPOSFN,FNC,0 RPOS(N)
DESCR RPOSSP,0,0
DESCR RTABFN,FNC,0 RTAB(N)
DESCR RTABSP,0,0
DESCR SIZEFN,FNC,0 SIZE(S)
DESCR SIZESP,0,0
DESCR SPANFN,FNC,0 SPAN(CS)
DESCR SPANSP,0,0
DESCR STPTFN,FNC,0 STOPTR(V,R)
DESCR STPTSP,0,0
DESCR TABFN,FNC,0 TAB(N)
DESCR TABSP,0,0
DESCR ASSCFN,FNC,0 TABLE(N,M)
DESCR ASSCSP,0,0
DESCR TIMFN,FNC,0 TIME()
DESCR TIMSP,0,0
DESCR TRCEFN,FNC,0 TRACE(V,R,T,F)
DESCR TRCESP,0,0
DESCR TRIMFN,FNC,0 TRIM(S)
DESCR TRMSP,0,0
DESCR UNLDFN,FNC,0 UNLOAD(S)
DESCR UNLDSP,0,0
DESCR VALFN,FNC,0 VALUE(S)
DESCR VALSP,0,0
ARRAY 10*2 Space for 10 more functions
FNCPLE LHERE , End of function pair list
OPTBL DESCR OPTBL,TTL+MARK,OPTBND-OPTBL-DESCR
ADDFN DESCR ADD,0,2 X + Y addition
DESCR 0,0,0
DESCR 30,0,29
BIAMFN DESCR UNDF,FNC,0 X & Y definable
DESCR 0,0,0
DESCR 5,0,4
BIATFN DESCR UNDF,FNC,0 X @ Y definable
DESCR 0,0,0
DESCR 25,0,24
BINGFN DESCR UNDF,FNC,0 X \ Y definable
DESCR 0,0,0
DESCR 70,0,70
BIPDFN DESCR UNDF,FNC,0 X # Y definable
DESCR 0,0,0
DESCR 35,0,34
BIPRFN DESCR UNDF,FNC,0 X % Y definable
DESCR 0,0,0
DESCR 45,0,44
BIQSFN DESCR UNDF,FNC,0 X ? Y definable
DESCR 0,0,0
DESCR 70,0,69
CONFN DESCR CON,0,2 X Y concatenation
DESCR 0,0,0
DESCR 20,0,19
DIVFN DESCR DIV,0,2 X / Y division
DESCR 0,0,0
DESCR 40,0,39
DOLFN DESCR DOL,0,2 X $ Y immediate naming
DESCR 0,0,0
DESCR 60,0,59
EXPFN DESCR EXP,0,2 X ** Y exponentiation
DESCR 0,0,0
DESCR 50,0,50
MPYFN DESCR MPY,0,2 X * Y multiplication
DESCR 0,0,0
DESCR 42,0,41
NAMFN DESCR NAM,0,2 X . Y naming
DESCR 0,0,0
DESCR 60,0,59
ORFN DESCR OR,0,2 X | Y alternation
DESCR 0,0,0
DESCR 10,0,9
SUBFN DESCR SUB,0,2 X - Y subtraction
DESCR 0,0,0
DESCR 30,0,29
AROWFN DESCR UNDF,FNC,0 !X definable
DESCR 0,0,0
ATFN DESCR ATOP,0,1 @X scanner position
DESCR 0,0,0
BARFN DESCR UNDF,FNC,0 |X definable
DESCR 0,0,0
DOTFN DESCR NAME,0,1 .X name
DESCR 0,0,0
INDFN DESCR IND,0,1 $X indirect reference
DESCR 0,0,0
KEYFN DESCR KEYWRD,0,1 &X keyword
DESCR 0,0,0
MNSFN DESCR MNS,0,1 -X minus
DESCR 0,0,0
NEGFN DESCR NEG,0,1 \X negation
DESCR 0,0,0
PDFN DESCR UNDF,FNC,0 #X definable
DESCR 0,0,0
PLSFN DESCR PLS,0,1 +X plus
DESCR 0,0,0
PRFN DESCR UNDF,FNC,0 %X definable
DESCR 0,0,0
QUESFN DESCR QUES,0,1 ?X interrogation
DESCR 0,0,0
SLHFN DESCR UNDF,FNC,0 /X definable
DESCR 0,0,0
STRFN DESCR STR,0,1 *X unevaluated expression
DESCR 0,0,0
OPTBND LHERE , End of operator table
*
*
AREFN DESCR ITEM,FNC,1 Array or table reference
ASGNFN DESCR ASGN,0,2 X = Y
BASEFN DESCR BASE,0,0 Base object code
ENDAFN DESCR ARGNER,0,0 Safety exit on trace psuedo-code
ENDFN DESCR END,0,0 End of program
ERORFN DESCR EROR,0,1 Erroneous statement
FNTRFN DESCR FENTR,0,2 Call tracing
FXTRFN DESCR FNEXTR,0,2 Return tracing
GOTGFN DESCR GOTG,0,1 :<X>
GOTLFN DESCR GOTL,0,1 :(L)
GOTOFN DESCR GOTO,0,1 Internal goto
INITFN DESCR INIT,0,1 Statement initialization
KEYTFN DESCR KEYTR,0,2 Keyword tracing
LABTFN DESCR LABTR,0,2 Label tracing
LITFN DESCR LIT,0,1 Literal evaluation
SCANFN DESCR SCAN,0,2 Pattern matching
SJSRFN DESCR SJSR,0,3 Pattern matching with replacement
VLTRFN DESCR VALTR,0,2 Value tracing
ANYCFN DESCR ANYC,0,3 Matching for ANY(S)
ARBFFN DESCR ARBF,0,2 Failure for ARB
ARBNFN DESCR ARBN,0,2 Matching for ARBNO(P)
ATOPFN DESCR ATP,0,3 Matching for @X
CHRFN DESCR CHR,0,3 Matching for string
BALFN DESCR BAL,0,2 Matching for BAL
BALFFN DESCR BALF,0,2 Failure for BAL
BRKCFN DESCR BRKC,0,3 Matching for BREAK(S)
DNMEFN DESCR DNME,0,2
DNMIFN DESCR DNME1,0,2
EARBFN DESCR EARB,0,2
DSARFN DESCR DSAR,0,3
ENMEFN DESCR ENME,0,3
ENMIFN DESCR ENMI,0,3
FARBFN DESCR FARB,0,2
FNMEFN DESCR FNME,0,2
LNTHFN DESCR LNTH,0,3 Matching for LEN(N)
NMEFN DESCR NME,0,2
NNYCFN DESCR NNYC,0,3 Matching for NOTANY(S)
ONARFN DESCR ONAR,0,2
ONRFFN DESCR ONRF,0,2
POSIFN DESCR POSI,0,3 Matching for POS(N)
RPSIFN DESCR RPSI,0,3 Matching for RPOS(N)
RTBFN DESCR RTB,0,3 Matching for RTAB(N)
SALFFN DESCR SALF,0,2
SCFLFN DESCR FAIL,0,2
SCOKFN DESCR SCOK,0,2 Successful match procedure
SCONFN DESCR SCON,0,2
SPNCFN DESCR SPNC,0,3 Matching for SPAN(S)
STARFN DESCR STAR,0,3 Matching for *X
TBFN DESCR TB,0,3 Matching for TAB(N)
ABORFN DESCR RTNUL3,0,3 Matching for ABORT
FNCEFN DESCR FNCE,0,2 Matching for FENCE
FNCFFN DESCR RTNUL3,0,2 Failure for FENCE
SUCFFN DESCR SUCF,0,2 Matching for SUCCEED
*
* Initialization Data for Functions
*
ABNDSP STRING 'ABEND'
ABORSP STRING 'ABORT'
ALNMSP STRING 'ALPHABET'
ANCHSP STRING 'ANCHOR'
ANYSP STRING 'ANY'
APLYSP STRING 'APPLY'
ARBSP STRING 'ARB'
ARBNSP STRING 'ARBNO'
ARGSP STRING 'ARG'
BACKSP STRING 'BACKSPACE'
BALSP STRING 'BAL'
BRKSP STRING 'BREAK'
TRFRSP STRING 'CALL'
CLERSP STRING 'CLEAR'
CODESP STRING 'CODE'
CLSP STRING 'COLLECT'
CNVTSP STRING 'CONVERT'
COPYSP STRING 'COPY'
DATSP STRING 'DATE'
DATASP STRING 'DATA'
DEFISP STRING 'DEFINE'
DIFFSP STRING 'DIFFER'
DTCHSP STRING 'DETACH'
DTSP STRING 'DATATYPE'
DUMPSP STRING 'DUMP'
DUPLSP STRING 'DUPL'
ENDSP STRING 'END'
ENDFSP STRING 'ENDFILE'
EQSP STRING 'EQ'
ERRLSP STRING 'ERRLIMIT'
ERRTSP STRING 'ERRTYPE'
EVALSP STRING 'EVAL'
EXPSP STRING 'EXPRESSION'
FAILSP STRING 'FAIL'
FNCESP STRING 'FENCE'
FLDSSP STRING 'FIELD'
FNCLSP STRING 'FNCLEVEL'
FRETSP STRING 'FRETURN'
FTRCSP STRING 'FTRACE'
FULLSP STRING 'FULLSCAN'
FUNTSP STRING 'FUNCTION'
GESP STRING 'GE'
GTSP STRING 'GT'
IDENSP STRING 'IDENT'
INSP STRING 'INPUT'
INTGSP STRING 'INTEGER'
ITEMSP STRING 'ITEM'
TRKYSP STRING 'KEYWORD'
TRLASP STRING 'LABEL'
LSTNSP STRING 'LASTNO'
LENSP STRING 'LEN'
LESP STRING 'LE'
LGTSP STRING 'LGT'
LOADSP STRING 'LOAD'
LOCSP STRING 'LOCAL'
LTSP STRING 'LT'
MAXLSP STRING 'MAXLNGTH'
NAMESP STRING 'NAME'
NESP STRING 'NE'
NNYSP STRING 'NOTANY'
NRETSP STRING 'NRETURN'
OPSNSP STRING 'OPSYN'
OUTSP STRING 'OUTPUT'
PATSP STRING 'PATTERN'
POSSP STRING 'POS'
PRTSP STRING 'PROTOTYPE'
PNCHSP STRING 'PUNCH'
RLSP STRING 'REAL'
REMSP STRING 'REM'
REMDSP STRING 'REMDR'
RETSP STRING 'RETURN'
REWNSP STRING 'REWIND'
RPLCSP STRING 'REPLACE'
RPOSSP STRING 'RPOS'
RTABSP STRING 'RTAB'
RTYPSP STRING 'RTNTYPE'
SIZESP STRING 'SIZE'
SPANSP STRING 'SPAN'
STCTSP STRING 'STCOUNT'
STFCSP STRING 'STFCOUNT'
STLMSP STRING 'STLIMIT'
STPTSP STRING 'STOPTR'
STNOSP STRING 'STNO'
VARSP STRING 'STRING'
SUCCSP STRING 'SUCCEED'
TABSP STRING 'TAB'
TIMSP STRING 'TIME'
TRCESP STRING 'TRACE'
TRMSP STRING 'TRIM'
UNLDSP STRING 'UNLOAD'
VALSP STRING 'VALUE'
*
CRDFSP STRING '(80A1)' Default output format
OUTPSP STRING '(1X,132A1)' Standard print format
*
* Pointers to Other Initialization
*
ABNDB LHERE ,
DESCR ALPHSP,0,0 &ALPHABET
DESCR ALPHVL,0,0
DESCR CRDFSP,0,0 Default output format
DESCR DFLFST,0,0
DESCR EXDTSP,0,0 'EXTERNAL'
DESCR EXTPTR,0,0
DESCR ENDSP,0,0 'END'
DESCR ENDPTR,0,0
DESCR FRETSP,0,0 'FRETURN'
DESCR FRETCL,0,0
DESCR FUNTSP,0,0 'FUNCTION'
DESCR FUNTCL,0,0
DESCR NRETSP,0,0 'NRETURN'
DESCR NRETCL,0,0
DESCR RETSP,0,0 'RETURN'
DTEND DESCR RETCL,0,0
BUFEXT EQU DTEND-ANYSP
BUFLEN EQU BUFEXT*CPA
*
* System Arrays
*
PRMTBL DESCR PRMTBL,TTL+MARK,PRMSIZ
DESCR DTLIST,0,0 Data type pair list
DESCR FNLIST,0,0 Function pair list
DESCR FTABLE,0,0 Procedure descriptor table
DESCR ICLBLK,0,0 Miscellaneous data
DESCR KNLIST,0,0 Unprotected keyword pair list
DESCR KVLIST,0,0 Protected keyword pair list
DESCR OPTBL,0,0 Operator procedure descriptors
DESCR STACK,0,0 Interpreter stack
DESCR INLIST,0,0 Input association pair list
DESCR OTLIST,0,0 Output association pair list
DESCR INSATL,0,0 Input block list
DESCR OTSATL,0,0 Output block list
DESCR TFENPL,0,0 Call trace pair list
DESCR TFEXPL,0,0 Return trace pair list
DESCR TKEYPL,0,0 Keyword trace pair list
DESCR TLABPL,0,0 Label trace pair list
DESCR TRLIST,0,0 Trace pair list
DESCR TVALPL,0,0 Value trace pair list
PRMTRM LHERE , End of basic block list
PRMSIZ EQU PRMTRM-PRMTBL-DESCR Size of basic block list
*
* String Storage Bin List
*
OBLOCK DESCR OBLOCK,TTL+MARK,OBARY*DESCR
ARRAY 3 Pseudo heading
OBSTRT ARRAY OBSIZ Bin list
OBLIST EQU OBSTRT-LNKFLD Pseudo link pointer
*
* Pattern Matching History List
*
PDLBLK DESCR PDLBLK,TTL+MARK,SPDLSZ*DESCR
ARRAY SPDLSZ Pattern history list
*
* SYSTEM STACK
*
STACK DESCR STACK,TTL+MARK,STSIZE*DESCR
ARRAY STSIZE Interpreter stack
*
* Primitive Patterns
*
ABORPT DESCR ABORPT,TTL+MARK,3*DESCR
DESCR ABORFN,FNC,2 ABORT
DESCR 0,0,0
DESCR 0,0,0
*
ARBAK DESCR ARBAK,TTL+MARK,6*DESCR
DESCR ONARFN,FNC,2
DESCR 3*DESCR,0,0
DESCR 0,0,0
DESCR ONRFFN,FNC,2
DESCR 0,0,0
DESCR 0,0,0
*
ARBPT DESCR ARBPT,TTL+MARK,9*DESCR
DESCR SCOKFN,FNC,2 ARB
DESCR 0,0,3*DESCR
DESCR 0,0,0
DESCR SCOKFN,FNC,2
DESCR 6*DESCR,0,0
DESCR 0,0,0
DESCR FARBFN,FNC,2
DESCR 6*DESCR,0,0
DESCR 0,0,0
*
ARHED DESCR ARHED,TTL+MARK,12*DESCR
DESCR SCOKFN,FNC,2
DESCR 0,0,3*DESCR
DESCR 0,0,0
DESCR SCOKFN,FNC,2
DESCR 6*DESCR,0,0
DESCR 0,0,0
DESCR ARBNFN,FNC,2
DESCR 9*DESCR,0,12*DESCR
DESCR 0,0,0
DESCR ARBFFN,FNC,2
DESCR 0,0,0
DESCR 0,0,0
*
ARTAL DESCR ARTAL,TTL+MARK,6*DESCR
DESCR EARBFN,FNC,2
DESCR 0,0,3*DESCR
DESCR 0,0,0
DESCR SCOKFN,FNC,2
DESCR 6*DESCR,0,0
DESCR 0,0,0
*
BALPT DESCR BALPT,TTL+MARK,9*DESCR
DESCR SCOKFN,FNC,2 BAL
DESCR 0,0,3*DESCR
DESCR 0,0,0
DESCR BALFN,FNC,2
DESCR 6*DESCR,0,0
DESCR 0,0,0
DESCR BALFFN,FNC,2
DESCR 6*DESCR,0,0
DESCR 0,0,0
*
FAILPT DESCR FAILPT,TTL+MARK,3*DESCR
DESCR SALFFN,FNC,2 FAIL
DESCR 0,0,0
DESCR 0,0,0
*
FNCEPT DESCR FNCEPT,TTL+MARK,3*DESCR
DESCR FNCEFN,FNC,2 FENCE
DESCR 0,0,0
DESCR 0,0,0
*
REMPT DESCR REMPT,TTL+MARK,4*DESCR
DESCR RTBFN,FNC,3 REM
DESCR 0,0,0
DESCR 0,0,0
DESCR 0,0,I
*
STARPT DESCR STARPT,TTL+MARK,11*DESCR
DESCR STARFN,FNC,3
DESCR 0,0,4*DESCR
DESCR 1,0,0
DESCR 0,0,0
DESCR SCOKFN,FNC,2
DESCR 7*DESCR,0,0
DESCR 0,0,0
DESCR DSARFN,FNC,3
DESCR 0,0,4*DESCR
DESCR 0,0,0
DESCR 0,0,0
*
SUCCPT DESCR SUCCPT,TTL+MARK,3*DESCR
DESCR SUCFFN,FNC,2 SUCCEED
DESCR 0,0,0
DESCR 0,0,0
*
TVALPL DESCR TVALPL,TTL+MARK,2*DESCR
DESCR 0,0,0 VALUE trace
DESCR 0,0,0
TLABPL DESCR TLABPL,TTL+MARK,2*DESCR
DESCR 0,0,0 LABEL trace
DESCR 0,0,0
TFENPL DESCR TFENPL,TTL+MARK,2*DESCR
DESCR 0,0,0 CALL trace
DESCR 0,0,0
TFEXPL DESCR TFEXPL,TTL+MARK,2*DESCR
DESCR 0,0,0 RETURN trace
DESCR 0,0,0
TKEYPL DESCR TKEYPL,TTL+MARK,2*DESCR
DESCR 0,0,0 KEYWORD trace
DESCR 0,0,0
*
VALBLK DESCR VALBLK,TTL+MARK,6*DESCR
DESCR 0,0,S STRING
DESCR 0,0,0 0 offset
DESCR 0,0,N NAME
DESCR 0,0,0 0 offset
DESCR 0,0,K KEYWORD (NAME)
DESCR 0,0,0 0 offset
*
* Fatal Error Message Pointers
*
MSGLST DESCR 0,0,0
DESCR MSG1,0,0
DESCR MSG2,0,0
DESCR MSG3,0,0
DESCR MSG4,0,0
DESCR MSG5,0,0
DESCR MSG6,0,0
DESCR MSG7,0,0
DESCR MSG8,0,0
DESCR MSG9,0,0
DESCR MSG10,0,0
DESCR MSG11,0,0
DESCR MSG12,0,0
DESCR MSG13,0,0
DESCR MSG14,0,0
DESCR MSG15,0,0
DESCR MSG16,0,0
DESCR MSG17,0,0
DESCR MSG18,0,0
DESCR MSG19,0,0
DESCR MSG20,0,0
DESCR MSG21,0,0
DESCR MSG22,0,0
DESCR MSG23,0,0
DESCR MSG24,0,0
DESCR MSG25,0,0
DESCR MSG26,0,0
DESCR MSG27,0,0
DESCR MSG28,0,0
*
* Fatal Error Messages
*
MSG1 STRING 'ILLEGAL DATA TYPE'
MSG2 STRING 'ERROR IN ARITHMETIC OPERATION'
MSG3 STRING 'ERRONEOUS ARRAY OR TABLE REFERENCE'
MSG4 STRING 'NULL STRING IN ILLEGAL CONTEXT'
MSG5 STRING 'UNDEFINED FUNCTION OR OPERATION'
MSG6 STRING 'ERRONEOUS PROTOTYPE'
MSG7 STRING 'UNKNOWN KEYWORD'
MSG8 STRING 'VARIABLE NOT PRESENT WHERE REQUIRED'
MSG9 STRING 'ENTRY POINT OF FUNCTION NOT LABEL'
MSG10 STRING 'ILLEGAL ARGUMENT TO PRIMITIVE FUNCTION'
MSG11 STRING 'READING ERROR'
MSG12 STRING 'ILLEGAL I/O UNIT'
MSG13 STRING 'LIMIT ON DEFINED DATA TYPES EXCEEDED'
MSG14 STRING 'NEGATIVE NUMBER IN ILLEGAL CONTEXT'
MSG15 STRING 'STRING OVERFLOW'
MSG16 STRING 'OVERFLOW DURING PATTERN MATCHING'
MSG17 STRING 'ERROR IN SNOBOL4 SYSTEM'
MSG18 STRING 'RETURN FROM LEVEL ZERO'
MSG19 STRING 'FAILURE DURING GOTO EVALUATION'
MSG20 STRING 'INSUFFICIENT STORAGE TO CONTINUE'
MSG21 STRING 'STACK OVERFLOW'
MSG22 STRING 'LIMIT ON STATEMENT EXECUTION EXCEEDED'
MSG23 STRING 'OBJECT EXCEEDS SIZE LIMIT'
MSG24 STRING 'UNDEFINED OR ERRONEOUS GOTO'
MSG25 STRING 'INCORRECT NUMBER OF ARGUMENTS'
MSG26 STRING 'LIMIT ON COMPILATION ERRORS EXCEEDED'
MSG27 STRING 'ERRONEOUS END STATEMENT'
MSG28 STRING 'EXECUTION OF STATEMENT WITH COMPILATION ERROR'
*
* Compiler Error Messages
*
EMSG1 STRING 'ERRONEOUS LABEL'
EMSG2 STRING 'PREVIOUSLY DEFINED LABEL'
EMSG3 STRING 'ERRONEOUS SUBJECT'
EMSG14 STRING 'ERROR IN GOTO'
ILCHAR STRING 'ILLEGAL CHARACTER IN ELEMENT'
ILLBIN STRING 'BINARY OPERATOR MISSING OR IN ERROR'
ILLBRK STRING 'ERRONEOUS OR MISSING BREAK CHARACTER'
ILLDEC STRING 'ERRONEOUS REAL NUMBER'
ILLEOS STRING 'IMPROPERLY TERMINATED STATEMENT'
ILLINT STRING 'ERRONEOUS INTEGER'
OPNLIT STRING 'UNCLOSED LITERAL'
*
* Formats
*
ALOCFL FORMAT '(40H0INSUFFICIENT STORAGE FOR INITIALIZATION)' E3.10.6
ARTHNO FORMAT '(1H0,I15,32H ARITHMETIC OPERATIONS PERFORMED)'
CMTIME FORMAT '(1H0,I15,21H MS. COMPILATION TIME)'
EJECTF FORMAT '(1H1)'
ERRCF FORMAT '(34H0ERRORS DETECTED IN SOURCE PROGRAM/1H1)'
EXNO FORMAT '(1H0,I15,21H STATEMENTS EXECUTED,,I8,7H FAILED)'
FTLCF FORMAT '(6H1ERROR,I3,13H IN STATEMENT,I5,9H AT LEVEL,I3)'
* E3.4.1
INCGCF FORMAT '(33H1INCOMPLETE STORAGE REGENERATION.)'
INTIME FORMAT '(1H0,I15,19H MS. EXECUTION TIME)'
LASTSF FORMAT '(28H LAST STATEMENT EXECUTED WAS,I5)'
NODMPF FORMAT '(28H1TERMINAL DUMP NOT POSSIBLE.)'
NRMEND FORMAT '(28H1NORMAL TERMINATION AT LEVEL,I3)'
NVARF FORMAT '(18H0NATURAL VARIABLES,/1H )'
PKEYF FORMAT '(21H0UNPROTECTED KEYWORDS/1H )'
PRTOVF FORMAT '(29H ***PRINT REQUEST TOO LONG***)'
READNO FORMAT '(1H0,I15,16H READS PERFORMED)'
SCANNO FORMAT '(1H0,I15,26H PATTERN MATCHES PERFORMED)'
SOURCF FORMAT '(42H0BELL TELEPHONE LABORATORIES, INCORPORATED,/1H1)'
STATHD FORMAT '(28H1SNOBOL4 STATISTICS SUMMARY-)'
STDMP FORMAT '(33H1DUMP OF VARIABLES AT TERMINATION/1H )'
STGENO FORMAT '(1H0,I15,33H REGENERATIONS OF DYNAMIC STORAGE)'
SUCCF FORMAT '(37H0NO ERRORS DETECTED IN SOURCE PROGRAM/1H1)'
SYSCMT FORMAT '(27H0CUT BY SYSTEM IN STATEMENT,I5,9H AT LEVEL,I3)'
* E3.4.1
TIMEPS FORMAT '(1H0,F15.2,35H MS. AVERAGE PER STATEMENT EXECUTED/1H1)'
TITLEF FORMAT '(37H1SNOBOL4 (VERSION 3.11, MAY 19, 1975)/8H+_______)'
* V3.11
WRITNO FORMAT '(1H0,I15,17H WRITES PERFORMED)'
END